diff options
Diffstat (limited to 'lisp')
48 files changed, 2419 insertions, 2012 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index f413526c0b2..674b26716a4 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog | |||
| @@ -1,7 +1,319 @@ | |||
| 1 | 2015-01-10 Lars Magne Ingebrigtsen <larsi@gnus.org> | ||
| 2 | |||
| 3 | * net/shr.el (shr-urlify): Don't bother the user about | ||
| 4 | invalidly-encoded display strings. | ||
| 5 | |||
| 6 | 2015-01-10 Ivan Shmakov <ivan@siamics.net> | ||
| 7 | |||
| 8 | * net/shr.el (shr-urlify): Decode URLs before using them as titles | ||
| 9 | (bug#19555). | ||
| 10 | |||
| 11 | 2015-01-10 Lars Magne Ingebrigtsen <larsi@gnus.org> | ||
| 12 | |||
| 13 | * net/eww.el (eww): Always interpret URLs that start with https?: | ||
| 14 | as plain URLs, even if they have spaces in them (bug#19556). | ||
| 15 | (eww): Also interpret things like "en.wikipedia.org/wiki/Free | ||
| 16 | software" as an URL. | ||
| 17 | (eww): Don't interpret "org/foo" as an URL. | ||
| 18 | (eww): Clear the title when loading so that we don't display | ||
| 19 | misleading information. | ||
| 20 | |||
| 21 | 2015-01-10 Daniel Colascione <dancol@dancol.org> | ||
| 22 | |||
| 23 | * vc/vc-hooks.el (vc-prefix-map): Bind vc-delete-file to C-x v x, | ||
| 24 | by analogy with dired. | ||
| 25 | |||
| 26 | 2015-01-09 Daniel Colascione <dancol@dancol.org> | ||
| 27 | |||
| 28 | * progmodes/js.el (js--function-heading-1-re) | ||
| 29 | (js--function-prologue-beginning): Parse ES6 generator function | ||
| 30 | declarations. (That is, "function* name()"). | ||
| 31 | |||
| 32 | 2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 33 | |||
| 34 | * emacs-lisp/eieio.el (defclass): Move from eieio-defclass all the code | ||
| 35 | that creates functions, and most of the sanity checks. | ||
| 36 | Mark as obsolete the <class>-child-p function. | ||
| 37 | * emacs-lisp/eieio-core.el (eieio--define-field-accessors): Remove. | ||
| 38 | (eieio--class, eieio--object): Use cl-defstruct. | ||
| 39 | (eieio--object-num-slots): Define manually. | ||
| 40 | (eieio-defclass-autoload): Use eieio--class-make. | ||
| 41 | (eieio-defclass-internal): Rename from eieio-defclass. Move all the | ||
| 42 | `(lambda...) definitions and most of the sanity checks to `defclass'. | ||
| 43 | Mark as obsolete the <class>-list-p function, the <class> variable and | ||
| 44 | the <initarg> variables. Use pcase-dolist. | ||
| 45 | (eieio-defclass): New compatibility function. | ||
| 46 | * emacs-lisp/eieio-opt.el (eieio-build-class-alist) | ||
| 47 | (eieio-class-speedbar): Don't use eieio-default-superclass var. | ||
| 48 | |||
| 49 | 2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 50 | |||
| 51 | * emacs-lisp/eieio-generic.el: New file. | ||
| 52 | * emacs-lisp/eieio-core.el: Move all generic function code to | ||
| 53 | eieio-generic.el. | ||
| 54 | (eieio--defmethod): Declare. | ||
| 55 | |||
| 56 | * emacs-lisp/eieio.el: Require eieio-generic. Move all generic | ||
| 57 | function code to eieio-generic.el. | ||
| 58 | * emacs-lisp/eieio-opt.el (eieio-help-generic): Move to | ||
| 59 | eieio-generic.el. | ||
| 60 | * emacs-lisp/eieio-datadebug.el (eieio-debug-methodinvoke): Update call | ||
| 61 | to eieio--generic-call. | ||
| 62 | * emacs-lisp/eieio-base.el (eieio-instance-inheritor): Don't use | ||
| 63 | <class>-child type. | ||
| 64 | |||
| 65 | 2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 66 | |||
| 67 | * emacs-lisp/chart.el (chart-add-sequence, chart-bar-quickie): | ||
| 68 | Don't use <class> as a variable. | ||
| 69 | |||
| 70 | * emacs-lisp/eieio.el (same-class-p): Accept class object as well. | ||
| 71 | (call-next-method): Simplify. | ||
| 72 | (clone): Obey eieio-backward-compatibility. | ||
| 73 | |||
| 74 | * emacs-lisp/eieio-opt.el (eieio-read-generic-p): Remove. | ||
| 75 | (eieio-read-generic): Use `generic-p' instead. | ||
| 76 | |||
| 77 | * emacs-lisp/eieio-core.el (eieio-backward-compatibility): New var. | ||
| 78 | (eieio-defclass-autoload): Obey it. | ||
| 79 | (eieio--class-object): Improve error behavior. | ||
| 80 | (eieio-class-children-fast, same-class-fast-p): Remove. Inline at | ||
| 81 | every use site. | ||
| 82 | (eieio--defgeneric-form-primary-only): Rename from | ||
| 83 | eieio-defgeneric-form-primary-only; update all callers. | ||
| 84 | (eieio--defgeneric-form-primary-only-one): Rename from | ||
| 85 | eieio-defgeneric-form-primary-only-one; update all callers. | ||
| 86 | (eieio-defgeneric-reset-generic-form) | ||
| 87 | (eieio-defgeneric-reset-generic-form-primary-only) | ||
| 88 | (eieio-defgeneric-reset-generic-form-primary-only-one): Remove. | ||
| 89 | (eieio--method-optimize-primary): New function to replace them. | ||
| 90 | (eieio--defmethod, eieio-defmethod): Use it. | ||
| 91 | (eieio--perform-slot-validation): Rename from | ||
| 92 | eieio-perform-slot-validation; update all callers. | ||
| 93 | (eieio--validate-slot-value): Rename from eieio-validate-slot-value. | ||
| 94 | Change `class' to be a class object. Update all callers. | ||
| 95 | (eieio--validate-class-slot-value): Rename from | ||
| 96 | eieio-validate-class-slot-value. Change `class' to be a class object. | ||
| 97 | Update all callers. | ||
| 98 | (eieio-oset-default): Accept class object as well. | ||
| 99 | (eieio--generic-call-primary-only): Rename from | ||
| 100 | eieio-generic-call-primary-only. Update all callers. | ||
| 101 | |||
| 102 | * emacs-lisp/eieio-base.el (eieio-persistent-validate/fix-slot-value): | ||
| 103 | Improve error messages. | ||
| 104 | (eieio-persistent-slot-type-is-class-p): Handle `list-of' types, as | ||
| 105 | well as user-defined types. Emit errors for legacy types like | ||
| 106 | <class>-child and <class>-list, if not eieio-backward-compatibility. | ||
| 107 | |||
| 108 | 2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 109 | |||
| 110 | * emacs-lisp/eieio.el (eieio-class-parents): Accept class objects. | ||
| 111 | (eieio--class-slot-initarg): Rename from class-slot-initarg. | ||
| 112 | Change `class' arg to be a class object. Update all callers. | ||
| 113 | (call-next-method): Adjust to new return value of `eieio-generic-form'. | ||
| 114 | (eieio-default-superclass): Set var to the class object. | ||
| 115 | (eieio-edebug-prin1-to-string): Fix recursive call for lists. | ||
| 116 | Change print behavior to affect class objects rather than | ||
| 117 | class symbols. | ||
| 118 | |||
| 119 | * emacs-lisp/eieio-core.el (eieio-class-object): New function. | ||
| 120 | (eieio-class-parents-fast): Remove macro. | ||
| 121 | (eieio--class-option-assoc): Rename from class-option-assoc. | ||
| 122 | Update all callers. | ||
| 123 | (eieio--class-option): Rename from class-option. Change `class' arg to | ||
| 124 | be a class object. Update all callers. | ||
| 125 | (eieio--class-method-invocation-order): Rename from | ||
| 126 | class-method-invocation-order. Change `class' arg to be a class | ||
| 127 | object. Update all callers. | ||
| 128 | (eieio-defclass-autoload, eieio-defclass): Set the `parent' field to | ||
| 129 | a list of class objects rather than names. | ||
| 130 | (eieio-defclass): Remove redundant quotes. Use `eieio-oref-default' | ||
| 131 | for accessors to class allocated slots. | ||
| 132 | (eieio--perform-slot-validation-for-default): Rename from | ||
| 133 | eieio-perform-slot-validation-for-default. Update all callers. | ||
| 134 | (eieio--add-new-slot): Rename from eieio-add-new-slot. | ||
| 135 | Update all callers. Use push. | ||
| 136 | (eieio-copy-parents-into-subclass): Adjust to new content of | ||
| 137 | `parent' field. Use dolist. | ||
| 138 | (eieio-oref): Remove support for providing a class rather than | ||
| 139 | an object. | ||
| 140 | (eieio-oref-default): Prefer class objects over class names. | ||
| 141 | (eieio--slot-originating-class-p): Rename from | ||
| 142 | eieio-slot-originating-class-p. Update all callers. Use `or'. | ||
| 143 | (eieio--slot-name-index): Turn check into assertion. | ||
| 144 | (eieio--class-slot-name-index): Rename from | ||
| 145 | eieio-class-slot-name-index. Change `class' arg to be a class object. | ||
| 146 | Update all callers. | ||
| 147 | (eieio-attribute-to-initarg): Move to eieio-test-persist.el. | ||
| 148 | (eieio--c3-candidate): Rename from eieio-c3-candidate. | ||
| 149 | Update all callers. | ||
| 150 | (eieio--c3-merge-lists): Rename from eieio-c3-merge-lists. | ||
| 151 | Update all callers. | ||
| 152 | (eieio--class-precedence-c3): Rename from eieio-class-precedence-c3. | ||
| 153 | Update all callers. | ||
| 154 | (eieio--class-precedence-dfs): Rename from eieio-class-precedence-dfs. | ||
| 155 | Update all callers. | ||
| 156 | (eieio--class-precedence-bfs): Rename from eieio-class-precedence-bfs. | ||
| 157 | Update all callers. Adjust to new `parent' content. | ||
| 158 | (eieio--class-precedence-list): Rename from -class-precedence-list. | ||
| 159 | Update all callers. | ||
| 160 | (eieio-generic-call): Use autoloadp and autoload-do-load. | ||
| 161 | Slight simplification. | ||
| 162 | (eieio-generic-call, eieio-generic-call-primary-only): Adjust to new | ||
| 163 | return value of `eieio-generic-form'. | ||
| 164 | (eieiomt-add): Index the hashtable with class objects rather than | ||
| 165 | class names. | ||
| 166 | (eieio-generic-form): Accept class objects as well. | ||
| 167 | |||
| 168 | * emacs-lisp/eieio-base.el (eieio-persistent-convert-list-to-object): | ||
| 169 | Adjust to new convention for eieio-persistent-validate/fix-slot-value. | ||
| 170 | (eieio-persistent-validate/fix-slot-value): | ||
| 171 | Change `class' arg to be a class object. Update all callers. | ||
| 172 | |||
| 173 | 2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 174 | |||
| 175 | * emacs-lisp/eieio.el (child-of-class-p): Make it accept class objects | ||
| 176 | additionally to class names. | ||
| 177 | |||
| 178 | * emacs-lisp/eieio-core.el (eieio--with-scoped-class): Use let-binding. | ||
| 179 | (object): Remove first (constant) slot; rename second to `class-tag'. | ||
| 180 | (eieio--object-class-object, eieio--object-class-name): New funs | ||
| 181 | to replace eieio--object-class. | ||
| 182 | (eieio--class-object, eieio--class-p): New functions. | ||
| 183 | (same-class-fast-p): Make it a defsubst, change its implementation | ||
| 184 | to check the class objects rather than their names. | ||
| 185 | (eieio-object-p): Rewrite. | ||
| 186 | (eieio-defclass): Adjust the object initialization according to the new | ||
| 187 | object layout. | ||
| 188 | (eieio--scoped-class): Declare it returns a class object (not a class | ||
| 189 | name any more). Adjust calls accordingly (along with calls to | ||
| 190 | eieio--with-scoped-class). | ||
| 191 | (eieio--slot-name-index): Rename from eieio-slot-name-index and change | ||
| 192 | its class arg to be a class object. Adjust callers accordingly. | ||
| 193 | (eieio-slot-originating-class-p): Make its start-class arg a class | ||
| 194 | object. Adjust all callers. | ||
| 195 | (eieio--initarg-to-attribute): Rename from eieio-initarg-to-attribute. | ||
| 196 | Make its `class' arg a class object. Adjust all callers. | ||
| 197 | |||
| 198 | * emacs-lisp/eieio-base.el (eieio-persistent-validate/fix-slot-value): | ||
| 199 | Use eieio--slot-name-index rather than eieio-slot-name-index. | ||
| 200 | |||
| 201 | 2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 202 | |||
| 203 | * emacs-lisp/eieio.el (make-instance): Simplify by not adding an object | ||
| 204 | name argument. | ||
| 205 | (eieio-object-name): Use eieio-object-name-string. | ||
| 206 | (eieio--object-names): New const. | ||
| 207 | (eieio-object-name-string, eieio-object-set-name-string): Re-implement | ||
| 208 | using a hashtable rather than a built-in slot. | ||
| 209 | (eieio-constructor): Rename from `constructor'. Remove `newname' arg. | ||
| 210 | (clone): Don't mess with the object's "name". | ||
| 211 | |||
| 212 | * emacs-lisp/eieio-custom.el (eieio-widget-test): Remove dummy arg. | ||
| 213 | (eieio-object-value-get): Use eieio-object-set-name-string. | ||
| 214 | |||
| 215 | * emacs-lisp/eieio-core.el (eieio--defalias): Follow aliases. | ||
| 216 | (eieio--object): Remove `name' field. | ||
| 217 | (eieio-defclass): Adjust to new convention where constructors don't | ||
| 218 | take an "object name" any more. | ||
| 219 | (eieio--defgeneric-init-form, eieio--defmethod): Follow aliases. | ||
| 220 | (eieio-validate-slot-value, eieio-oset-default) | ||
| 221 | (eieio-slot-name-index): Don't hardcode eieio--object-num-slots. | ||
| 222 | (eieio-generic-call-primary-only): Simplify. | ||
| 223 | |||
| 224 | * emacs-lisp/eieio-base.el (clone) <eieio-instance-inheritor>: | ||
| 225 | Use call-next-method. | ||
| 226 | (eieio-constructor): Rename from `constructor'. | ||
| 227 | (eieio-persistent-convert-list-to-object): Drop objname. | ||
| 228 | (eieio-persistent-validate/fix-slot-value): Don't hardcode | ||
| 229 | eieio--object-num-slots. | ||
| 230 | (eieio-named): Use a normal slot. | ||
| 231 | (slot-missing) <eieio-named>: Remove. | ||
| 232 | (eieio-object-name-string, eieio-object-set-name-string, clone) | ||
| 233 | <eieio-named>: New methods. | ||
| 234 | |||
| 235 | 2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 236 | |||
| 237 | * emacs-lisp/eieio-core.el (eieio--class-v): Rename from class-v. | ||
| 238 | (method-*): Add a "eieio--" prefix to those constants. | ||
| 239 | |||
| 240 | * emacs-lisp/eieio.el: Move edebug specs to the corresponding macro. | ||
| 241 | |||
| 242 | * emacs-lisp/eieio-speedbar.el: Use lexical-binding. | ||
| 243 | |||
| 244 | 2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 245 | |||
| 246 | * emacs-lisp/eieio.el (child-of-class-p): Fix case where `class' is | ||
| 247 | `eieio-default-superclass'. | ||
| 248 | |||
| 249 | * emacs-lisp/eieio-datadebug.el: Use lexical-binding. | ||
| 250 | |||
| 251 | * emacs-lisp/eieio-custom.el: Use lexical-binding. | ||
| 252 | (eieio-object-value-to-abstract): Simplify. | ||
| 253 | |||
| 254 | * emacs-lisp/eieio-opt.el (eieio-build-class-list): Use cl-mapcan. | ||
| 255 | (eieio-build-class-alist): Use dolist. | ||
| 256 | (eieio-all-generic-functions): Adjust to use of hashtables. | ||
| 257 | |||
| 258 | * emacs-lisp/eieio-core.el (class): Rename field symbol-obarray to | ||
| 259 | symbol-hashtable. It contains a hashtable instead of an obarray. | ||
| 260 | (generic-p): Use symbol property `eieio-method-hashtable' instead of | ||
| 261 | `eieio-method-obarray'. | ||
| 262 | (generic-primary-only-p, generic-primary-only-one-p): | ||
| 263 | Slight optimization. | ||
| 264 | (eieio-defclass-autoload-map): Use a hashtable instead of an obarray. | ||
| 265 | (eieio-defclass-autoload, eieio-defclass): Adjust/simplify accordingly. | ||
| 266 | (eieio-class-un-autoload): Use autoload-do-load. | ||
| 267 | (eieio-defclass): Use dolist, cl-pushnew, cl-callf. | ||
| 268 | Use new cl-deftype-satisfies. Adjust to use of hashtables. | ||
| 269 | Don't hardcode the value of eieio--object-num-slots. | ||
| 270 | (eieio-defgeneric-form-primary-only-one): Remove `doc-string' arg. | ||
| 271 | Use a closure rather than a backquoted lambda. | ||
| 272 | (eieio--defmethod): Adjust call accordingly. Set doc-string via the | ||
| 273 | function-documentation property. | ||
| 274 | (eieio-slot-originating-class-p, eieio-slot-name-index) | ||
| 275 | (eieiomt--optimizing-hashtable, eieiomt-install, eieiomt-add) | ||
| 276 | (eieio-generic-form): Adjust to use of hashtables. | ||
| 277 | (eieiomt--sym-optimize): Rename from eieiomt-sym-optimize; take | ||
| 278 | additional class argument. | ||
| 279 | (eieio-generic-call-methodname): Remove, unused. | ||
| 280 | |||
| 281 | * emacs-lisp/eieio-base.el (eieio-persistent-slot-type-is-class-p): | ||
| 282 | Prefer \' to $. | ||
| 283 | |||
| 284 | 2015-01-08 Eli Zaretskii <eliz@gnu.org> | ||
| 285 | |||
| 286 | * simple.el (line-move-visual): When converting X pixel coordinate | ||
| 287 | to temporary-goal-column, adjust the value for right-to-left | ||
| 288 | screen lines. This fixes vertical-motion, next/prev-line, etc. | ||
| 289 | |||
| 290 | 2015-01-08 Glenn Morris <rgm@gnu.org> | ||
| 291 | |||
| 292 | * files.el (file-tree-walk): Remove; of unknown authorship. (Bug#19325) | ||
| 293 | |||
| 294 | 2015-01-07 K. Handa <handa@gnu.org> | ||
| 295 | |||
| 296 | * international/ccl.el (define-ccl-program): Improve the docstring. | ||
| 297 | |||
| 298 | 2015-01-06 Sam Steingold <sds@gnu.org> | ||
| 299 | |||
| 300 | * shell.el (shell-display-buffer-actions): Remove, | ||
| 301 | use `display-buffer-alist' instead. | ||
| 302 | |||
| 303 | 2015-01-05 Dmitry Gutov <dgutov@yandex.ru> | ||
| 304 | |||
| 305 | * progmodes/xref.el (xref--insert-xrefs): Add `help-echo' property | ||
| 306 | to the references. | ||
| 307 | |||
| 308 | 2015-01-05 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 309 | |||
| 310 | * minibuffer.el (completion-category-defaults): New var. | ||
| 311 | Set unicode-name to use substring completion. | ||
| 312 | (completion-category-defaults): Set it to nil. | ||
| 313 | |||
| 1 | 2015-01-04 Dmitry Gutov <dgutov@yandex.ru> | 314 | 2015-01-04 Dmitry Gutov <dgutov@yandex.ru> |
| 2 | 315 | ||
| 3 | Add mouse interaction to xref. | 316 | Add mouse interaction to xref. |
| 4 | |||
| 5 | * progmodes/xref.el (xref--button-map): New variable. | 317 | * progmodes/xref.el (xref--button-map): New variable. |
| 6 | (xref--mouse-2): New command. | 318 | (xref--mouse-2): New command. |
| 7 | (xref--insert-xrefs): Add `mouse-face' and `keymap' properties to | 319 | (xref--insert-xrefs): Add `mouse-face' and `keymap' properties to |
| @@ -30,7 +342,6 @@ | |||
| 30 | 2015-01-04 Dmitry Gutov <dgutov@yandex.ru> | 342 | 2015-01-04 Dmitry Gutov <dgutov@yandex.ru> |
| 31 | 343 | ||
| 32 | Unbreak `mouse-action' property in text buttons. | 344 | Unbreak `mouse-action' property in text buttons. |
| 33 | |||
| 34 | * button.el (push-button): Fix regression from 2012-12-06. | 345 | * button.el (push-button): Fix regression from 2012-12-06. |
| 35 | 346 | ||
| 36 | 2015-01-03 Dmitry Gutov <dgutov@yandex.ru> | 347 | 2015-01-03 Dmitry Gutov <dgutov@yandex.ru> |
| @@ -144,11 +455,9 @@ | |||
| 144 | 2014-12-29 Dmitry Gutov <dgutov@yandex.ru> | 455 | 2014-12-29 Dmitry Gutov <dgutov@yandex.ru> |
| 145 | 456 | ||
| 146 | Unbreak jumping to an alias's definition. | 457 | Unbreak jumping to an alias's definition. |
| 147 | |||
| 148 | * emacs-lisp/find-func.el (find-function-library): Return a pair | 458 | * emacs-lisp/find-func.el (find-function-library): Return a pair |
| 149 | (ORIG-FUNCTION . LIBRARY) instead of just its second element. | 459 | (ORIG-FUNCTION . LIBRARY) instead of just its second element. |
| 150 | (find-function-noselect): Use it. | 460 | (find-function-noselect): Use it. |
| 151 | |||
| 152 | * progmodes/elisp-mode.el (elisp--xref-identifier-file): Rename to | 461 | * progmodes/elisp-mode.el (elisp--xref-identifier-file): Rename to |
| 153 | `elisp--xref-identifier-location', incorporate logic from | 462 | `elisp--xref-identifier-location', incorporate logic from |
| 154 | `elisp--xref-find-definitions', use the changed | 463 | `elisp--xref-find-definitions', use the changed |
| @@ -217,7 +526,6 @@ | |||
| 217 | 2014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org> | 526 | 2014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org> |
| 218 | 527 | ||
| 219 | python.el: Native readline completion. | 528 | python.el: Native readline completion. |
| 220 | |||
| 221 | * progmodes/python.el (python-shell-completion-native-disabled-interpreters) | 529 | * progmodes/python.el (python-shell-completion-native-disabled-interpreters) |
| 222 | (python-shell-completion-native-enable) | 530 | (python-shell-completion-native-enable) |
| 223 | (python-shell-completion-native-output-timeout): New defcustoms. | 531 | (python-shell-completion-native-output-timeout): New defcustoms. |
| @@ -236,9 +544,8 @@ | |||
| 236 | 544 | ||
| 237 | python.el: Enhance shell user interaction and deprecate | 545 | python.el: Enhance shell user interaction and deprecate |
| 238 | python-shell-get-or-create-process. | 546 | python-shell-get-or-create-process. |
| 239 | 547 | * progmodes/python.el (python-shell-get-process-or-error): | |
| 240 | * progmodes/python.el | 548 | New function. |
| 241 | (python-shell-get-process-or-error): New function. | ||
| 242 | (python-shell-with-shell-buffer): Use it. | 549 | (python-shell-with-shell-buffer): Use it. |
| 243 | (python-shell-send-string, python-shell-send-region) | 550 | (python-shell-send-string, python-shell-send-region) |
| 244 | (python-shell-send-buffer, python-shell-send-defun) | 551 | (python-shell-send-buffer, python-shell-send-defun) |
| @@ -266,22 +573,15 @@ | |||
| 266 | 2014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org> | 573 | 2014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org> |
| 267 | 574 | ||
| 268 | python.el: Fix message when sending region. | 575 | python.el: Fix message when sending region. |
| 269 | |||
| 270 | * progmodes/python.el (python-shell-send-region): Rename argument | 576 | * progmodes/python.el (python-shell-send-region): Rename argument |
| 271 | send-main from nomain. Fix message. | 577 | send-main from nomain. Fix message. |
| 272 | (python-shell-send-buffer): Rename argument send-main from arg. | 578 | (python-shell-send-buffer): Rename argument send-main from arg. |
| 273 | 579 | ||
| 274 | 2014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org> | ||
| 275 | |||
| 276 | python.el: Cleanup temp files even with eval errors. | 580 | python.el: Cleanup temp files even with eval errors. |
| 277 | |||
| 278 | * progmodes/python.el (python-shell-send-file): Make file-name | 581 | * progmodes/python.el (python-shell-send-file): Make file-name |
| 279 | mandatory. Fix temp file removal in the majority of cases. | 582 | mandatory. Fix temp file removal in the majority of cases. |
| 280 | 583 | ||
| 281 | 2014-12-27 Fabián Ezequiel Gallina <fgallina@gnu.org> | ||
| 282 | |||
| 283 | python.el: Handle file encoding for shell. | 584 | python.el: Handle file encoding for shell. |
| 284 | |||
| 285 | * progmodes/python.el (python-rx-constituents): Add coding-cookie. | 585 | * progmodes/python.el (python-rx-constituents): Add coding-cookie. |
| 286 | (python-shell--save-temp-file): Write file with proper encoding. | 586 | (python-shell--save-temp-file): Write file with proper encoding. |
| 287 | (python-shell-buffer-substring): Add coding cookie for detected | 587 | (python-shell-buffer-substring): Add coding cookie for detected |
| @@ -343,7 +643,7 @@ | |||
| 343 | 643 | ||
| 344 | 2014-12-27 Stefan Monnier <monnier@iro.umontreal.ca> | 644 | 2014-12-27 Stefan Monnier <monnier@iro.umontreal.ca> |
| 345 | 645 | ||
| 346 | * lisp/subr.el (redisplay-dont-pause): Mark as obsolete. | 646 | * subr.el (redisplay-dont-pause): Mark as obsolete. |
| 347 | 647 | ||
| 348 | 2014-12-27 Michael Albinus <michael.albinus@gmx.de> | 648 | 2014-12-27 Michael Albinus <michael.albinus@gmx.de> |
| 349 | 649 | ||
| @@ -416,7 +716,6 @@ | |||
| 416 | 2014-12-26 Fabián Ezequiel Gallina <fgallina@gnu.org> | 716 | 2014-12-26 Fabián Ezequiel Gallina <fgallina@gnu.org> |
| 417 | 717 | ||
| 418 | python.el: Generate clearer shell buffer names. | 718 | python.el: Generate clearer shell buffer names. |
| 419 | |||
| 420 | * progmodes/python.el (python-shell-get-process-name) | 719 | * progmodes/python.el (python-shell-get-process-name) |
| 421 | (python-shell-internal-get-process-name): Use `buffer-name`. | 720 | (python-shell-internal-get-process-name): Use `buffer-name`. |
| 422 | (python-shell-internal-get-or-create-process): Simplify. | 721 | (python-shell-internal-get-or-create-process): Simplify. |
| @@ -539,7 +838,7 @@ | |||
| 539 | 2014-12-19 Alan Mackenzie <acm@muc.de> | 838 | 2014-12-19 Alan Mackenzie <acm@muc.de> |
| 540 | 839 | ||
| 541 | Make C++11 uniform init syntax work. | 840 | Make C++11 uniform init syntax work. |
| 542 | New keywords "final" and "override" | 841 | New keywords "final" and "override". |
| 543 | * progmodes/cc-engine.el (c-back-over-member-initializer-braces): | 842 | * progmodes/cc-engine.el (c-back-over-member-initializer-braces): |
| 544 | New function. | 843 | New function. |
| 545 | (c-guess-basic-syntax): Set `containing-sex' and `lim' using the | 844 | (c-guess-basic-syntax): Set `containing-sex' and `lim' using the |
| @@ -575,8 +874,7 @@ | |||
| 575 | 874 | ||
| 576 | 2014-12-18 Artur Malabarba <bruce.connor.am@gmail.com> | 875 | 2014-12-18 Artur Malabarba <bruce.connor.am@gmail.com> |
| 577 | 876 | ||
| 578 | * let-alist.el (let-alist): Evaluate the `alist' argument only | 877 | * let-alist.el (let-alist): Evaluate the `alist' argument only once. |
| 579 | once. | ||
| 580 | 878 | ||
| 581 | 2014-12-18 Sam Steingold <sds@gnu.org> | 879 | 2014-12-18 Sam Steingold <sds@gnu.org> |
| 582 | 880 | ||
| @@ -590,13 +888,12 @@ | |||
| 590 | Add code for "preserving" window sizes. | 888 | Add code for "preserving" window sizes. |
| 591 | * dired.el (dired-pop-to-buffer): Call fit-window-to-buffer with | 889 | * dired.el (dired-pop-to-buffer): Call fit-window-to-buffer with |
| 592 | `preserve-size' t. | 890 | `preserve-size' t. |
| 593 | (dired-mark-pop-up): Preserve size of window showing marked | 891 | (dired-mark-pop-up): Preserve size of window showing marked files. |
| 594 | files. | ||
| 595 | * electric.el (Electric-pop-up-window): | 892 | * electric.el (Electric-pop-up-window): |
| 596 | * help.el (resize-temp-buffer-window): Call fit-window-to-buffer | 893 | * help.el (resize-temp-buffer-window): Call fit-window-to-buffer |
| 597 | with `preserve-size' t. | 894 | with `preserve-size' t. |
| 598 | * minibuffer.el (minibuffer-completion-help): Use | 895 | * minibuffer.el (minibuffer-completion-help): |
| 599 | `resize-temp-buffer-window' instead of `fit-window-to-buffer' | 896 | Use `resize-temp-buffer-window' instead of `fit-window-to-buffer' |
| 600 | (Bug#19355). Preserve size of completions window. | 897 | (Bug#19355). Preserve size of completions window. |
| 601 | * register.el (register-preview): Preserve size of register | 898 | * register.el (register-preview): Preserve size of register |
| 602 | preview window. | 899 | preview window. |
| @@ -606,8 +903,7 @@ | |||
| 606 | `window-preserve-size'. | 903 | `window-preserve-size'. |
| 607 | (window-min-pixel-size, window--preservable-size) | 904 | (window-min-pixel-size, window--preservable-size) |
| 608 | (window-preserve-size, window-preserved-size) | 905 | (window-preserve-size, window-preserved-size) |
| 609 | (window--preserve-size, window--min-size-ignore-p): New | 906 | (window--preserve-size, window--min-size-ignore-p): New functions. |
| 610 | functions. | ||
| 611 | (window-min-size, window-min-delta, window--resizable) | 907 | (window-min-size, window-min-delta, window--resizable) |
| 612 | (window--resize-this-window, split-window-below) | 908 | (window--resize-this-window, split-window-below) |
| 613 | (split-window-right): Amend doc-string. | 909 | (split-window-right): Amend doc-string. |
| @@ -622,8 +918,7 @@ | |||
| 622 | window above or below. | 918 | window above or below. |
| 623 | (window--state-put-2): Handle horizontal scroll bars. | 919 | (window--state-put-2): Handle horizontal scroll bars. |
| 624 | (window--display-buffer): Call `preserve-size' if asked for. | 920 | (window--display-buffer): Call `preserve-size' if asked for. |
| 625 | (display-buffer): Mention `preserve-size' alist member in | 921 | (display-buffer): Mention `preserve-size' alist member in doc-string. |
| 626 | doc-string. | ||
| 627 | (fit-window-to-buffer): New argument PRESERVE-SIZE. | 922 | (fit-window-to-buffer): New argument PRESERVE-SIZE. |
| 628 | * textmodes/ispell.el (ispell-command-loop): Suppress horizontal | 923 | * textmodes/ispell.el (ispell-command-loop): Suppress horizontal |
| 629 | scroll bar on ispell's windows. Don't count window lines and | 924 | scroll bar on ispell's windows. Don't count window lines and |
| @@ -711,7 +1006,7 @@ | |||
| 711 | 1006 | ||
| 712 | 2014-12-14 Alan Mackenzie <acm@muc.de> | 1007 | 2014-12-14 Alan Mackenzie <acm@muc.de> |
| 713 | 1008 | ||
| 714 | * lisp/cus-start.el (all): Add fast-but-imprecise-scrolling. | 1009 | * cus-start.el (all): Add fast-but-imprecise-scrolling. |
| 715 | 1010 | ||
| 716 | 2014-12-14 Artur Malabarba <bruce.connor.am@gmail.com> | 1011 | 2014-12-14 Artur Malabarba <bruce.connor.am@gmail.com> |
| 717 | 1012 | ||
| @@ -1857,7 +2152,7 @@ | |||
| 1857 | 2152 | ||
| 1858 | 2014-11-19 Artur Malabarba <bruce.connor.am@gmail.com> | 2153 | 2014-11-19 Artur Malabarba <bruce.connor.am@gmail.com> |
| 1859 | 2154 | ||
| 1860 | * lisp/ido.el (ido-bury-buffer-at-head): New command. | 2155 | * ido.el (ido-bury-buffer-at-head): New command. |
| 1861 | (ido-buffer-completion-map): Bind it to C-S-b. | 2156 | (ido-buffer-completion-map): Bind it to C-S-b. |
| 1862 | 2157 | ||
| 1863 | 2014-11-18 Juri Linkov <juri@linkov.net> | 2158 | 2014-11-18 Juri Linkov <juri@linkov.net> |
diff --git a/lisp/cedet/ChangeLog b/lisp/cedet/ChangeLog index 367ed9f41c8..5c958350ff0 100644 --- a/lisp/cedet/ChangeLog +++ b/lisp/cedet/ChangeLog | |||
| @@ -1,3 +1,52 @@ | |||
| 1 | 2015-01-07 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 2 | |||
| 3 | Don't use <class> as a variable and don't assume that <class>-list-p is | ||
| 4 | automatically defined. | ||
| 5 | |||
| 6 | * ede/speedbar.el (ede-speedbar-compile-line) | ||
| 7 | (ede-speedbar-get-top-project-for-line): | ||
| 8 | * ede.el (ede-buffer-belongs-to-target-p) | ||
| 9 | (ede-buffer-belongs-to-project-p, ede-build-forms-menu) | ||
| 10 | (ede-add-project-to-global-list): | ||
| 11 | * semantic/db-typecache.el (semanticdb-get-typecache): | ||
| 12 | * semantic/db-file.el (semanticdb-load-database): | ||
| 13 | * semantic/db-el.el (semanticdb-elisp-sym->tag): | ||
| 14 | * semantic/db-ebrowse.el (semanticdb-ebrowse-load-helper): | ||
| 15 | * ede/project-am.el (project-am-preferred-target-type): | ||
| 16 | * ede/proj.el (ede-proj-load): | ||
| 17 | * ede/custom.el (ede-customize-current-target, ede-customize-target): | ||
| 18 | * semantic/ede-grammar.el ("semantic grammar"): | ||
| 19 | * semantic/scope.el (semantic-scope-reset-cache) | ||
| 20 | (semantic-calculate-scope): | ||
| 21 | * srecode/map.el (srecode-map-update-map): | ||
| 22 | * srecode/insert.el (srecode-insert-show-error-report) | ||
| 23 | (srecode-insert-method, srecode-insert-include-lookup) | ||
| 24 | (srecode-insert-method): | ||
| 25 | * srecode/fields.el (srecode-active-template-region): | ||
| 26 | * srecode/compile.el (srecode-flush-active-templates) | ||
| 27 | (srecode-compile-inserter): Don't use <class> as a variable. | ||
| 28 | Use `oref-default' for class slots. | ||
| 29 | |||
| 30 | * semantic/grammar.el (semantic-grammar-eldoc-last-data): New var. | ||
| 31 | (semantic-grammar-eldoc-get-macro-docstring): Use it instead of | ||
| 32 | eldoc-last-data. | ||
| 33 | * semantic/fw.el (semantic-exit-on-input): Use `declare'. | ||
| 34 | (semantic-throw-on-input): Use `with-current-buffer'. | ||
| 35 | * semantic/db.el (semanticdb-abstract-table-list): Define if not | ||
| 36 | pre-defined. | ||
| 37 | * semantic/db-find.el (semanticdb-find-tags-collector): | ||
| 38 | Use save-current-buffer. | ||
| 39 | (semanticdb-find-tags-collector): Don't use <class> as a variable. | ||
| 40 | * semantic/complete.el (semantic-complete-active-default) | ||
| 41 | (semantic-complete-current-matched-tag): Declare. | ||
| 42 | (semantic-complete-inline-custom-type): Don't use <class> as a variable. | ||
| 43 | * semantic/bovine/make.el (semantic-analyze-possible-completions): | ||
| 44 | Use with-current-buffer. | ||
| 45 | * semantic.el (semantic-parser-warnings): Declare. | ||
| 46 | * ede/base.el (ede-target-list): Define if not pre-defined. | ||
| 47 | (ede-with-projectfile): Prefer find-file-noselect over | ||
| 48 | save-window-excursion. | ||
| 49 | |||
| 1 | 2014-12-22 Stefan Monnier <monnier@iro.umontreal.ca> | 50 | 2014-12-22 Stefan Monnier <monnier@iro.umontreal.ca> |
| 2 | 51 | ||
| 3 | * srecode/srt-mode.el (srecode-macro-help): Use eieio-class-children. | 52 | * srecode/srt-mode.el (srecode-macro-help): Use eieio-class-children. |
diff --git a/lisp/cedet/ede.el b/lisp/cedet/ede.el index edf87f640cf..87cfb85b2c2 100644 --- a/lisp/cedet/ede.el +++ b/lisp/cedet/ede.el | |||
| @@ -248,12 +248,12 @@ Argument LIST-O-O is the list of objects to choose from." | |||
| 248 | (let ((obj ede-object)) | 248 | (let ((obj ede-object)) |
| 249 | (if (consp obj) | 249 | (if (consp obj) |
| 250 | (setq obj (car obj))) | 250 | (setq obj (car obj))) |
| 251 | (and obj (obj-of-class-p obj ede-target)))) | 251 | (and obj (obj-of-class-p obj 'ede-target)))) |
| 252 | 252 | ||
| 253 | (defun ede-buffer-belongs-to-project-p () | 253 | (defun ede-buffer-belongs-to-project-p () |
| 254 | "Return non-nil if this buffer belongs to at least one project." | 254 | "Return non-nil if this buffer belongs to at least one project." |
| 255 | (if (or (null ede-object) (consp ede-object)) nil | 255 | (if (or (null ede-object) (consp ede-object)) nil |
| 256 | (obj-of-class-p ede-object-project ede-project))) | 256 | (obj-of-class-p ede-object-project 'ede-project))) |
| 257 | 257 | ||
| 258 | (defun ede-menu-obj-of-class-p (class) | 258 | (defun ede-menu-obj-of-class-p (class) |
| 259 | "Return non-nil if some member of `ede-object' is a child of CLASS." | 259 | "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." | |||
| 281 | ;; First, collect the build items from the project | 281 | ;; First, collect the build items from the project |
| 282 | (setq newmenu (append newmenu (ede-menu-items-build obj t))) | 282 | (setq newmenu (append newmenu (ede-menu-items-build obj t))) |
| 283 | ;; Second, declare the current target menu items | 283 | ;; Second, declare the current target menu items |
| 284 | (if (and ede-obj (ede-menu-obj-of-class-p ede-target)) | 284 | (if (and ede-obj (ede-menu-obj-of-class-p 'ede-target)) |
| 285 | (while ede-obj | 285 | (while ede-obj |
| 286 | (setq newmenu (append newmenu | 286 | (setq newmenu (append newmenu |
| 287 | (ede-menu-items-build (car ede-obj) t)) | 287 | (ede-menu-items-build (car ede-obj) t)) |
| @@ -1078,7 +1078,7 @@ On success, return the added project." | |||
| 1078 | (error "No project created to add to master list")) | 1078 | (error "No project created to add to master list")) |
| 1079 | (when (not (eieio-object-p proj)) | 1079 | (when (not (eieio-object-p proj)) |
| 1080 | (error "Attempt to add non-object to master project list")) | 1080 | (error "Attempt to add non-object to master project list")) |
| 1081 | (when (not (obj-of-class-p proj ede-project-placeholder)) | 1081 | (when (not (obj-of-class-p proj 'ede-project-placeholder)) |
| 1082 | (error "Attempt to add a non-project to the ede projects list")) | 1082 | (error "Attempt to add a non-project to the ede projects list")) |
| 1083 | (add-to-list 'ede-projects proj) | 1083 | (add-to-list 'ede-projects proj) |
| 1084 | proj) | 1084 | proj) |
| @@ -1099,6 +1099,8 @@ Flush the dead projects from the project cache." | |||
| 1099 | (ede-delete-project-from-global-list D)) | 1099 | (ede-delete-project-from-global-list D)) |
| 1100 | )) | 1100 | )) |
| 1101 | 1101 | ||
| 1102 | (defvar ede--disable-inode) ;Defined in ede/files.el. | ||
| 1103 | |||
| 1102 | (defun ede-global-list-sanity-check () | 1104 | (defun ede-global-list-sanity-check () |
| 1103 | "Perform a sanity check to make sure there are no duplicate projects." | 1105 | "Perform a sanity check to make sure there are no duplicate projects." |
| 1104 | (interactive) | 1106 | (interactive) |
diff --git a/lisp/cedet/ede/base.el b/lisp/cedet/ede/base.el index 9f4fa45ff3a..ce7857b53a3 100644 --- a/lisp/cedet/ede/base.el +++ b/lisp/cedet/ede/base.el | |||
| @@ -159,6 +159,9 @@ and querying them will cause the actual project to get loaded.") | |||
| 159 | ;; Projects can also affect how EDE works, by changing what appears in | 159 | ;; Projects can also affect how EDE works, by changing what appears in |
| 160 | ;; the EDE menu, or how some keys are bound. | 160 | ;; the EDE menu, or how some keys are bound. |
| 161 | ;; | 161 | ;; |
| 162 | (unless (fboundp 'ede-target-list-p) | ||
| 163 | (cl-deftype ede-target-list () '(list-of ede-target))) | ||
| 164 | |||
| 162 | (defclass ede-project (ede-project-placeholder) | 165 | (defclass ede-project (ede-project-placeholder) |
| 163 | ((subproj :initform nil | 166 | ((subproj :initform nil |
| 164 | :type list | 167 | :type list |
| @@ -287,16 +290,18 @@ All specific project types must derive from this project." | |||
| 287 | ;; | 290 | ;; |
| 288 | (defmacro ede-with-projectfile (obj &rest forms) | 291 | (defmacro ede-with-projectfile (obj &rest forms) |
| 289 | "For the project in which OBJ resides, execute FORMS." | 292 | "For the project in which OBJ resides, execute FORMS." |
| 290 | `(save-window-excursion | 293 | (declare (indent 1)) |
| 291 | (let* ((pf (if (obj-of-class-p ,obj ede-target) | 294 | (unless (symbolp obj) |
| 292 | (ede-target-parent ,obj) | 295 | (message "Beware! ede-with-projectfile's first arg is copied: %S" obj)) |
| 293 | ,obj)) | 296 | `(let* ((pf (if (obj-of-class-p ,obj 'ede-target) |
| 294 | (dbka (get-file-buffer (oref pf file)))) | 297 | (ede-target-parent ,obj) |
| 295 | (if (not dbka) (find-file (oref pf file)) | 298 | ,obj)) |
| 296 | (switch-to-buffer dbka)) | 299 | (dbka (get-file-buffer (oref pf file)))) |
| 300 | (with-current-buffer | ||
| 301 | (if (not dbka) (find-file-noselect (oref pf file)) | ||
| 302 | dbka) | ||
| 297 | ,@forms | 303 | ,@forms |
| 298 | (if (not dbka) (kill-buffer (current-buffer)))))) | 304 | (if (not dbka) (kill-buffer (current-buffer)))))) |
| 299 | (put 'ede-with-projectfile 'lisp-indent-function 1) | ||
| 300 | 305 | ||
| 301 | ;;; The EDE persistent cache. | 306 | ;;; The EDE persistent cache. |
| 302 | ;; | 307 | ;; |
diff --git a/lisp/cedet/ede/custom.el b/lisp/cedet/ede/custom.el index 3cc3a48c27a..a39b4880283 100644 --- a/lisp/cedet/ede/custom.el +++ b/lisp/cedet/ede/custom.el | |||
| @@ -61,7 +61,7 @@ | |||
| 61 | "Edit fields of the current target through EIEIO & Custom." | 61 | "Edit fields of the current target through EIEIO & Custom." |
| 62 | (interactive) | 62 | (interactive) |
| 63 | (require 'eieio-custom) | 63 | (require 'eieio-custom) |
| 64 | (if (not (obj-of-class-p ede-object ede-target)) | 64 | (if (not (obj-of-class-p ede-object 'ede-target)) |
| 65 | (error "Current file is not part of a target")) | 65 | (error "Current file is not part of a target")) |
| 66 | (ede-customize-target ede-object)) | 66 | (ede-customize-target ede-object)) |
| 67 | 67 | ||
| @@ -72,7 +72,7 @@ | |||
| 72 | "Edit fields of the current target through EIEIO & Custom. | 72 | "Edit fields of the current target through EIEIO & Custom. |
| 73 | OBJ is the target object to customize." | 73 | OBJ is the target object to customize." |
| 74 | (require 'eieio-custom) | 74 | (require 'eieio-custom) |
| 75 | (if (and obj (not (obj-of-class-p obj ede-target))) | 75 | (if (and obj (not (obj-of-class-p obj 'ede-target))) |
| 76 | (error "No logical target to customize")) | 76 | (error "No logical target to customize")) |
| 77 | (ede-customize obj)) | 77 | (ede-customize obj)) |
| 78 | 78 | ||
diff --git a/lisp/cedet/ede/proj.el b/lisp/cedet/ede/proj.el index 1ea16570467..fd789b3857d 100644 --- a/lisp/cedet/ede/proj.el +++ b/lisp/cedet/ede/proj.el | |||
| @@ -297,7 +297,7 @@ for the tree being read in. If ROOTPROJ is nil, then assume that | |||
| 297 | the PROJECT being read in is the root project." | 297 | the PROJECT being read in is the root project." |
| 298 | (save-excursion | 298 | (save-excursion |
| 299 | (let ((ret (eieio-persistent-read (concat project "Project.ede") | 299 | (let ((ret (eieio-persistent-read (concat project "Project.ede") |
| 300 | ede-proj-project)) | 300 | 'ede-proj-project)) |
| 301 | (subdirs (directory-files project nil "[^.].*" nil))) | 301 | (subdirs (directory-files project nil "[^.].*" nil))) |
| 302 | (if (not (object-of-class-p ret 'ede-proj-project)) | 302 | (if (not (object-of-class-p ret 'ede-proj-project)) |
| 303 | (error "Corrupt project file")) | 303 | (error "Corrupt project file")) |
diff --git a/lisp/cedet/ede/project-am.el b/lisp/cedet/ede/project-am.el index 75fd195105f..d0ca8091c90 100644 --- a/lisp/cedet/ede/project-am.el +++ b/lisp/cedet/ede/project-am.el | |||
| @@ -853,13 +853,13 @@ Argument FILE is the file to extract the end directory name from." | |||
| 853 | (defun project-am-preferred-target-type (file) | 853 | (defun project-am-preferred-target-type (file) |
| 854 | "For FILE, return the preferred type for that file." | 854 | "For FILE, return the preferred type for that file." |
| 855 | (cond ((string-match "\\.texi?\\(nfo\\)$" file) | 855 | (cond ((string-match "\\.texi?\\(nfo\\)$" file) |
| 856 | project-am-texinfo) | 856 | 'project-am-texinfo) |
| 857 | ((string-match "\\.[0-9]$" file) | 857 | ((string-match "\\.[0-9]$" file) |
| 858 | project-am-man) | 858 | 'project-am-man) |
| 859 | ((string-match "\\.el$" file) | 859 | ((string-match "\\.el$" file) |
| 860 | project-am-lisp) | 860 | 'project-am-lisp) |
| 861 | (t | 861 | (t |
| 862 | project-am-program))) | 862 | 'project-am-program))) |
| 863 | 863 | ||
| 864 | (defmethod ede-buffer-header-file((this project-am-objectcode) buffer) | 864 | (defmethod ede-buffer-header-file((this project-am-objectcode) buffer) |
| 865 | "There are no default header files." | 865 | "There are no default header files." |
diff --git a/lisp/cedet/ede/speedbar.el b/lisp/cedet/ede/speedbar.el index fc26ec948a2..e08562a3738 100644 --- a/lisp/cedet/ede/speedbar.el +++ b/lisp/cedet/ede/speedbar.el | |||
| @@ -121,9 +121,9 @@ Argument DIR is the directory from which to derive the list of objects." | |||
| 121 | (let ((obj (eieio-speedbar-find-nearest-object))) | 121 | (let ((obj (eieio-speedbar-find-nearest-object))) |
| 122 | (if (not (eieio-object-p obj)) | 122 | (if (not (eieio-object-p obj)) |
| 123 | nil | 123 | nil |
| 124 | (cond ((obj-of-class-p obj ede-project) | 124 | (cond ((obj-of-class-p obj 'ede-project) |
| 125 | (project-compile-project obj)) | 125 | (project-compile-project obj)) |
| 126 | ((obj-of-class-p obj ede-target) | 126 | ((obj-of-class-p obj 'ede-target) |
| 127 | (project-compile-target obj)) | 127 | (project-compile-target obj)) |
| 128 | (t (error "Error in speedbar structure")))))) | 128 | (t (error "Error in speedbar structure")))))) |
| 129 | 129 | ||
| @@ -133,9 +133,9 @@ Argument DIR is the directory from which to derive the list of objects." | |||
| 133 | (let ((obj (eieio-speedbar-find-nearest-object))) | 133 | (let ((obj (eieio-speedbar-find-nearest-object))) |
| 134 | (if (not (eieio-object-p obj)) | 134 | (if (not (eieio-object-p obj)) |
| 135 | (error "Error in speedbar or ede structure") | 135 | (error "Error in speedbar or ede structure") |
| 136 | (if (obj-of-class-p obj ede-target) | 136 | (if (obj-of-class-p obj 'ede-target) |
| 137 | (setq obj (ede-target-parent obj))) | 137 | (setq obj (ede-target-parent obj))) |
| 138 | (if (obj-of-class-p obj ede-project) | 138 | (if (obj-of-class-p obj 'ede-project) |
| 139 | obj | 139 | obj |
| 140 | (error "Error in speedbar or ede structure"))))) | 140 | (error "Error in speedbar or ede structure"))))) |
| 141 | 141 | ||
diff --git a/lisp/cedet/semantic.el b/lisp/cedet/semantic.el index 7afe67b3207..81a97884554 100644 --- a/lisp/cedet/semantic.el +++ b/lisp/cedet/semantic.el | |||
| @@ -573,6 +573,7 @@ string." | |||
| 573 | ;; The best way to call the parser from programs is via | 573 | ;; The best way to call the parser from programs is via |
| 574 | ;; `semantic-fetch-tags'. This, in turn, uses other internal | 574 | ;; `semantic-fetch-tags'. This, in turn, uses other internal |
| 575 | ;; API functions which plug-in parsers can take advantage of. | 575 | ;; API functions which plug-in parsers can take advantage of. |
| 576 | (defvar semantic-parser-warnings) | ||
| 576 | 577 | ||
| 577 | (defun semantic-fetch-tags () | 578 | (defun semantic-fetch-tags () |
| 578 | "Fetch semantic tags from the current buffer. | 579 | "Fetch semantic tags from the current buffer. |
| @@ -602,49 +603,49 @@ was marked unparseable, then do nothing, and return the cache." | |||
| 602 | (garbage-collect) | 603 | (garbage-collect) |
| 603 | (cond | 604 | (cond |
| 604 | 605 | ||
| 605 | ;;;; Try the incremental parser to do a fast update. | 606 | ;; Try the incremental parser to do a fast update. |
| 606 | ((semantic-parse-tree-needs-update-p) | 607 | ((semantic-parse-tree-needs-update-p) |
| 607 | (setq res (semantic-parse-changes)) | 608 | (setq res (semantic-parse-changes)) |
| 608 | (if (semantic-parse-tree-needs-rebuild-p) | 609 | (if (semantic-parse-tree-needs-rebuild-p) |
| 609 | ;; If the partial reparse fails, jump to a full reparse. | 610 | ;; If the partial reparse fails, jump to a full reparse. |
| 610 | (semantic-fetch-tags) | 611 | (semantic-fetch-tags) |
| 611 | ;; Clear the cache of unmatched syntax tokens | 612 | ;; Clear the cache of unmatched syntax tokens |
| 612 | ;; | 613 | ;; |
| 613 | ;; NOTE TO SELF: | 614 | ;; NOTE TO SELF: |
| 614 | ;; | 615 | ;; |
| 615 | ;; Move this into the incremental parser. This is a bug. | 616 | ;; Move this into the incremental parser. This is a bug. |
| 616 | ;; | 617 | ;; |
| 617 | (semantic-clear-unmatched-syntax-cache) | 618 | (semantic-clear-unmatched-syntax-cache) |
| 618 | (run-hook-with-args ;; Let hooks know the updated tags | 619 | (run-hook-with-args ;; Let hooks know the updated tags |
| 619 | 'semantic-after-partial-cache-change-hook res)) | 620 | 'semantic-after-partial-cache-change-hook res)) |
| 620 | (setq semantic--completion-cache nil)) | 621 | (setq semantic--completion-cache nil)) |
| 621 | 622 | ||
| 622 | ;;;; Parse the whole system. | 623 | ;; Parse the whole system. |
| 623 | ((semantic-parse-tree-needs-rebuild-p) | 624 | ((semantic-parse-tree-needs-rebuild-p) |
| 624 | ;; Use Emacs's built-in progress-reporter (only interactive). | 625 | ;; Use Emacs's built-in progress-reporter (only interactive). |
| 625 | (if noninteractive | 626 | (if noninteractive |
| 626 | (setq res (semantic-parse-region (point-min) (point-max))) | 627 | (setq res (semantic-parse-region (point-min) (point-max))) |
| 627 | (let ((semantic--progress-reporter | 628 | (let ((semantic--progress-reporter |
| 628 | (and (>= (point-max) semantic-minimum-working-buffer-size) | 629 | (and (>= (point-max) semantic-minimum-working-buffer-size) |
| 629 | (eq semantic-working-type 'percent) | 630 | (eq semantic-working-type 'percent) |
| 630 | (make-progress-reporter | 631 | (make-progress-reporter |
| 631 | (semantic-parser-working-message (buffer-name)) | 632 | (semantic-parser-working-message (buffer-name)) |
| 632 | 0 100)))) | 633 | 0 100)))) |
| 633 | (setq res (semantic-parse-region (point-min) (point-max))) | 634 | (setq res (semantic-parse-region (point-min) (point-max))) |
| 634 | (if semantic--progress-reporter | 635 | (if semantic--progress-reporter |
| 635 | (progress-reporter-done semantic--progress-reporter)))) | 636 | (progress-reporter-done semantic--progress-reporter)))) |
| 636 | 637 | ||
| 637 | ;; Clear the caches when we see there were no errors. | 638 | ;; Clear the caches when we see there were no errors. |
| 638 | ;; But preserve the unmatched syntax cache and warnings! | 639 | ;; But preserve the unmatched syntax cache and warnings! |
| 639 | (let (semantic-unmatched-syntax-cache | 640 | (let (semantic-unmatched-syntax-cache |
| 640 | semantic-unmatched-syntax-cache-check | 641 | semantic-unmatched-syntax-cache-check |
| 641 | semantic-parser-warnings) | 642 | semantic-parser-warnings) |
| 642 | (semantic-clear-toplevel-cache)) | 643 | (semantic-clear-toplevel-cache)) |
| 643 | ;; Set up the new overlays | 644 | ;; Set up the new overlays |
| 644 | (semantic--tag-link-list-to-buffer res) | 645 | (semantic--tag-link-list-to-buffer res) |
| 645 | ;; Set up the cache with the new results | 646 | ;; Set up the cache with the new results |
| 646 | (semantic--set-buffer-cache res) | 647 | (semantic--set-buffer-cache res) |
| 647 | )))) | 648 | )))) |
| 648 | 649 | ||
| 649 | ;; Always return the current parse tree. | 650 | ;; Always return the current parse tree. |
| 650 | semantic--buffer-cache) | 651 | semantic--buffer-cache) |
diff --git a/lisp/cedet/semantic/bovine/make.el b/lisp/cedet/semantic/bovine/make.el index 6ba02ee2006..c001a4dab5f 100644 --- a/lisp/cedet/semantic/bovine/make.el +++ b/lisp/cedet/semantic/bovine/make.el | |||
| @@ -178,9 +178,8 @@ This is the same as a regular prototype." | |||
| 178 | makefile-mode (context) | 178 | makefile-mode (context) |
| 179 | "Return a list of possible completions in a Makefile. | 179 | "Return a list of possible completions in a Makefile. |
| 180 | Uses default implementation, and also gets a list of filenames." | 180 | Uses default implementation, and also gets a list of filenames." |
| 181 | (save-excursion | 181 | (require 'semantic/analyze/complete) |
| 182 | (require 'semantic/analyze/complete) | 182 | (with-current-buffer (oref context buffer) |
| 183 | (set-buffer (oref context buffer)) | ||
| 184 | (let* ((normal (semantic-analyze-possible-completions-default context)) | 183 | (let* ((normal (semantic-analyze-possible-completions-default context)) |
| 185 | (classes (oref context :prefixclass)) | 184 | (classes (oref context :prefixclass)) |
| 186 | (filetags nil)) | 185 | (filetags nil)) |
diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el index f1fbc7538c2..3f726ee56fd 100644 --- a/lisp/cedet/semantic/complete.el +++ b/lisp/cedet/semantic/complete.el | |||
| @@ -188,6 +188,8 @@ Value should be a ... what?") | |||
| 188 | "Default history variable for any unhistoried prompt. | 188 | "Default history variable for any unhistoried prompt. |
| 189 | Keeps STRINGS only in the history.") | 189 | Keeps STRINGS only in the history.") |
| 190 | 190 | ||
| 191 | (defvar semantic-complete-active-default) | ||
| 192 | (defvar semantic-complete-current-matched-tag) | ||
| 191 | 193 | ||
| 192 | (defun semantic-complete-read-tag-engine (collector displayor prompt | 194 | (defun semantic-complete-read-tag-engine (collector displayor prompt |
| 193 | default-tag initial-input | 195 | default-tag initial-input |
| @@ -1871,7 +1873,7 @@ completion text in ghost text." | |||
| 1871 | (list 'const | 1873 | (list 'const |
| 1872 | :tag doc1 | 1874 | :tag doc1 |
| 1873 | C))) | 1875 | C))) |
| 1874 | (eieio-build-class-alist semantic-displayor-abstract t)) | 1876 | (eieio-build-class-alist 'semantic-displayor-abstract t)) |
| 1875 | ) | 1877 | ) |
| 1876 | "Possible options for inline completion displayors. | 1878 | "Possible options for inline completion displayors. |
| 1877 | Use this to enable custom editing.") | 1879 | Use this to enable custom editing.") |
diff --git a/lisp/cedet/semantic/db-ebrowse.el b/lisp/cedet/semantic/db-ebrowse.el index 6ed3cdb7eb5..2590dd1208d 100644 --- a/lisp/cedet/semantic/db-ebrowse.el +++ b/lisp/cedet/semantic/db-ebrowse.el | |||
| @@ -192,7 +192,7 @@ is specified by `semanticdb-default-save-directory'." | |||
| 192 | If DIRECTORY is found to be defunct, it won't load the DB, and will | 192 | If DIRECTORY is found to be defunct, it won't load the DB, and will |
| 193 | warn instead." | 193 | warn instead." |
| 194 | (if (file-directory-p directory) | 194 | (if (file-directory-p directory) |
| 195 | (semanticdb-create-database semanticdb-project-database-ebrowse | 195 | (semanticdb-create-database 'semanticdb-project-database-ebrowse |
| 196 | directory) | 196 | directory) |
| 197 | (let* ((BF (semanticdb-ebrowse-file-for-directory directory)) | 197 | (let* ((BF (semanticdb-ebrowse-file-for-directory directory)) |
| 198 | (BFL (concat BF "-load.el")) | 198 | (BFL (concat BF "-load.el")) |
diff --git a/lisp/cedet/semantic/db-el.el b/lisp/cedet/semantic/db-el.el index 8b988be77bb..be9ffe31b87 100644 --- a/lisp/cedet/semantic/db-el.el +++ b/lisp/cedet/semantic/db-el.el | |||
| @@ -225,7 +225,7 @@ TOKTYPE is a hint to the type of tag desired." | |||
| 225 | (semantic-elisp-desymbolify | 225 | (semantic-elisp-desymbolify |
| 226 | ;; FIXME: This only gives the instance slots and ignores the | 226 | ;; FIXME: This only gives the instance slots and ignores the |
| 227 | ;; class-allocated slots. | 227 | ;; class-allocated slots. |
| 228 | (eieio--class-public-a (find-class semanticdb-project-database))) ;; slots ;FIXME: eieio-- | 228 | (eieio--class-public-a (find-class 'semanticdb-project-database))) ;; slots ;FIXME: eieio-- |
| 229 | (semantic-elisp-desymbolify (eieio-class-parents sym)) ;; parents | 229 | (semantic-elisp-desymbolify (eieio-class-parents sym)) ;; parents |
| 230 | )) | 230 | )) |
| 231 | ((not toktype) | 231 | ((not toktype) |
diff --git a/lisp/cedet/semantic/db-file.el b/lisp/cedet/semantic/db-file.el index 5b76d851b1d..0360e0680e7 100644 --- a/lisp/cedet/semantic/db-file.el +++ b/lisp/cedet/semantic/db-file.el | |||
| @@ -158,7 +158,8 @@ If DIRECTORY doesn't exist, create a new one." | |||
| 158 | (defun semanticdb-load-database (filename) | 158 | (defun semanticdb-load-database (filename) |
| 159 | "Load the database FILENAME." | 159 | "Load the database FILENAME." |
| 160 | (condition-case foo | 160 | (condition-case foo |
| 161 | (let* ((r (eieio-persistent-read filename semanticdb-project-database-file)) | 161 | (let* ((r (eieio-persistent-read filename |
| 162 | 'semanticdb-project-database-file)) | ||
| 162 | (c (semanticdb-get-database-tables r)) | 163 | (c (semanticdb-get-database-tables r)) |
| 163 | (tv (oref r semantic-tag-version)) | 164 | (tv (oref r semantic-tag-version)) |
| 164 | (fv (oref r semanticdb-version)) | 165 | (fv (oref r semanticdb-version)) |
diff --git a/lisp/cedet/semantic/db-find.el b/lisp/cedet/semantic/db-find.el index 08a22fb3b85..dd36cc1a01e 100644 --- a/lisp/cedet/semantic/db-find.el +++ b/lisp/cedet/semantic/db-find.el | |||
| @@ -1114,7 +1114,7 @@ for backward compatibility. | |||
| 1114 | If optional argument BRUTISH is non-nil, then ignore include statements, | 1114 | If optional argument BRUTISH is non-nil, then ignore include statements, |
| 1115 | and search all tables in this project tree." | 1115 | and search all tables in this project tree." |
| 1116 | (let (found match) | 1116 | (let (found match) |
| 1117 | (save-excursion | 1117 | (save-current-buffer |
| 1118 | ;; If path is a buffer, set ourselves up in that buffer | 1118 | ;; If path is a buffer, set ourselves up in that buffer |
| 1119 | ;; so that the override methods work correctly. | 1119 | ;; so that the override methods work correctly. |
| 1120 | (when (bufferp path) (set-buffer path)) | 1120 | (when (bufferp path) (set-buffer path)) |
| @@ -1127,7 +1127,7 @@ and search all tables in this project tree." | |||
| 1127 | ;; databases and not associated with a file. | 1127 | ;; databases and not associated with a file. |
| 1128 | (unless (and find-file-match | 1128 | (unless (and find-file-match |
| 1129 | (obj-of-class-p | 1129 | (obj-of-class-p |
| 1130 | (car tableandtags) semanticdb-search-results-table)) | 1130 | (car tableandtags) 'semanticdb-search-results-table)) |
| 1131 | (when (setq match (funcall function | 1131 | (when (setq match (funcall function |
| 1132 | (car tableandtags) (cdr tableandtags))) | 1132 | (car tableandtags) (cdr tableandtags))) |
| 1133 | (when find-file-match | 1133 | (when find-file-match |
| @@ -1144,7 +1144,7 @@ and search all tables in this project tree." | |||
| 1144 | ;; `semanticdb-search-results-table', since those are system | 1144 | ;; `semanticdb-search-results-table', since those are system |
| 1145 | ;; databases and not associated with a file. | 1145 | ;; databases and not associated with a file. |
| 1146 | (unless (and find-file-match | 1146 | (unless (and find-file-match |
| 1147 | (obj-of-class-p table semanticdb-search-results-table)) | 1147 | (obj-of-class-p table 'semanticdb-search-results-table)) |
| 1148 | (when (and table (setq match (funcall function table nil))) | 1148 | (when (and table (setq match (funcall function table nil))) |
| 1149 | (semanticdb-find-log-activity table match) | 1149 | (semanticdb-find-log-activity table match) |
| 1150 | (when find-file-match | 1150 | (when find-file-match |
diff --git a/lisp/cedet/semantic/db-typecache.el b/lisp/cedet/semantic/db-typecache.el index eb00a57cddd..723b7bd28bc 100644 --- a/lisp/cedet/semantic/db-typecache.el +++ b/lisp/cedet/semantic/db-typecache.el | |||
| @@ -180,7 +180,7 @@ If there is no table, create one, and fill it in." | |||
| 180 | (defmethod semanticdb-get-typecache ((db semanticdb-project-database)) | 180 | (defmethod semanticdb-get-typecache ((db semanticdb-project-database)) |
| 181 | "Retrieve the typecache from the semantic database DB. | 181 | "Retrieve the typecache from the semantic database DB. |
| 182 | If there is no table, create one, and fill it in." | 182 | If there is no table, create one, and fill it in." |
| 183 | (semanticdb-cache-get db semanticdb-database-typecache) | 183 | (semanticdb-cache-get db 'semanticdb-database-typecache) |
| 184 | ) | 184 | ) |
| 185 | 185 | ||
| 186 | 186 | ||
diff --git a/lisp/cedet/semantic/db.el b/lisp/cedet/semantic/db.el index 43e5e5b435b..b2c1252c502 100644 --- a/lisp/cedet/semantic/db.el +++ b/lisp/cedet/semantic/db.el | |||
| @@ -330,6 +330,10 @@ Adds the number of tags in this file to the object print name." | |||
| 330 | 330 | ||
| 331 | ;;; DATABASE BASE CLASS | 331 | ;;; DATABASE BASE CLASS |
| 332 | ;; | 332 | ;; |
| 333 | (unless (fboundp 'semanticdb-abstract-table-list-p) | ||
| 334 | (cl-deftype semanticdb-abstract-table-list () | ||
| 335 | '(list-of semanticdb-abstract-table))) | ||
| 336 | |||
| 333 | (defclass semanticdb-project-database (eieio-instance-tracker) | 337 | (defclass semanticdb-project-database (eieio-instance-tracker) |
| 334 | ((tracking-symbol :initform semanticdb-database-list) | 338 | ((tracking-symbol :initform semanticdb-database-list) |
| 335 | (reference-directory :type string | 339 | (reference-directory :type string |
diff --git a/lisp/cedet/semantic/ede-grammar.el b/lisp/cedet/semantic/ede-grammar.el index dc3dfa7f55a..67f0cfeea6d 100644 --- a/lisp/cedet/semantic/ede-grammar.el +++ b/lisp/cedet/semantic/ede-grammar.el | |||
| @@ -213,7 +213,7 @@ Argument THIS is the target that should insert stuff." | |||
| 213 | ;; "Target class for Emacs/Semantic grammar files." nil nil) | 213 | ;; "Target class for Emacs/Semantic grammar files." nil nil) |
| 214 | 214 | ||
| 215 | (ede-proj-register-target "semantic grammar" | 215 | (ede-proj-register-target "semantic grammar" |
| 216 | semantic-ede-proj-target-grammar) | 216 | 'semantic-ede-proj-target-grammar) |
| 217 | 217 | ||
| 218 | (provide 'semantic/ede-grammar) | 218 | (provide 'semantic/ede-grammar) |
| 219 | 219 | ||
diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el index 56adf3a6e81..a0c36944d48 100644 --- a/lisp/cedet/semantic/fw.el +++ b/lisp/cedet/semantic/fw.el | |||
| @@ -378,11 +378,11 @@ If FORMS includes a call to `semantic-throw-on-input', then | |||
| 378 | if a user presses any key during execution, this form macro | 378 | if a user presses any key during execution, this form macro |
| 379 | will exit with the value passed to `semantic-throw-on-input'. | 379 | will exit with the value passed to `semantic-throw-on-input'. |
| 380 | If FORMS completes, then the return value is the same as `progn'." | 380 | If FORMS completes, then the return value is the same as `progn'." |
| 381 | (declare (indent 1)) | ||
| 381 | `(let ((semantic-current-input-throw-symbol ,symbol) | 382 | `(let ((semantic-current-input-throw-symbol ,symbol) |
| 382 | (semantic--on-input-start-marker (point-marker))) | 383 | (semantic--on-input-start-marker (point-marker))) |
| 383 | (catch ,symbol | 384 | (catch ,symbol |
| 384 | ,@forms))) | 385 | ,@forms))) |
| 385 | (put 'semantic-exit-on-input 'lisp-indent-function 1) | ||
| 386 | 386 | ||
| 387 | (defmacro semantic-throw-on-input (from) | 387 | (defmacro semantic-throw-on-input (from) |
| 388 | "Exit with `throw' when in `semantic-exit-on-input' on user input. | 388 | "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 | |||
| 391 | calling this one." | 391 | calling this one." |
| 392 | `(when (and semantic-current-input-throw-symbol | 392 | `(when (and semantic-current-input-throw-symbol |
| 393 | (or (input-pending-p) | 393 | (or (input-pending-p) |
| 394 | (save-excursion | 394 | (with-current-buffer |
| 395 | ;; Timers might run during accept-process-output. | 395 | ;; Timers might run during accept-process-output. |
| 396 | ;; If they redisplay, point must be where the user | 396 | ;; If they redisplay, point must be where the user |
| 397 | ;; expects. (Bug#15045) | 397 | ;; expects. (Bug#15045) |
| 398 | (set-buffer (marker-buffer | 398 | (marker-buffer semantic--on-input-start-marker) |
| 399 | semantic--on-input-start-marker)) | 399 | (save-excursion |
| 400 | (goto-char (marker-position | 400 | (goto-char semantic--on-input-start-marker) |
| 401 | semantic--on-input-start-marker)) | 401 | (accept-process-output))))) |
| 402 | (accept-process-output)))) | ||
| 403 | (throw semantic-current-input-throw-symbol ,from))) | 402 | (throw semantic-current-input-throw-symbol ,from))) |
| 404 | 403 | ||
| 405 | 404 | ||
diff --git a/lisp/cedet/semantic/grammar.el b/lisp/cedet/semantic/grammar.el index fc62b221665..7a92a12ed53 100644 --- a/lisp/cedet/semantic/grammar.el +++ b/lisp/cedet/semantic/grammar.el | |||
| @@ -1665,13 +1665,14 @@ Select the buffer containing the tag's definition, and move point there." | |||
| 1665 | (declare-function eldoc-get-fnsym-args-string "eldoc") | 1665 | (declare-function eldoc-get-fnsym-args-string "eldoc") |
| 1666 | (declare-function eldoc-get-var-docstring "eldoc") | 1666 | (declare-function eldoc-get-var-docstring "eldoc") |
| 1667 | 1667 | ||
| 1668 | (defvar semantic-grammar-eldoc-last-data (cons nil nil)) | ||
| 1669 | |||
| 1668 | (defun semantic-grammar-eldoc-get-macro-docstring (macro expander) | 1670 | (defun semantic-grammar-eldoc-get-macro-docstring (macro expander) |
| 1669 | "Return a one-line docstring for the given grammar MACRO. | 1671 | "Return a one-line docstring for the given grammar MACRO. |
| 1670 | EXPANDER is the name of the function that expands MACRO." | 1672 | EXPANDER is the name of the function that expands MACRO." |
| 1671 | (require 'eldoc) | 1673 | (require 'eldoc) |
| 1672 | (if (and (eq expander (aref eldoc-last-data 0)) | 1674 | (if (eq expander (car semantic-grammar-eldoc-last-data)) |
| 1673 | (eq 'function (aref eldoc-last-data 2))) | 1675 | (cdr semantic-grammar-eldoc-last-data) |
| 1674 | (aref eldoc-last-data 1) | ||
| 1675 | (let ((doc (help-split-fundoc (documentation expander t) expander))) | 1676 | (let ((doc (help-split-fundoc (documentation expander t) expander))) |
| 1676 | (cond | 1677 | (cond |
| 1677 | (doc | 1678 | (doc |
| @@ -1684,7 +1685,7 @@ EXPANDER is the name of the function that expands MACRO." | |||
| 1684 | (setq doc | 1685 | (setq doc |
| 1685 | (eldoc-docstring-format-sym-doc | 1686 | (eldoc-docstring-format-sym-doc |
| 1686 | macro (format "==> %s %s" expander doc) 'default)) | 1687 | macro (format "==> %s %s" expander doc) 'default)) |
| 1687 | (eldoc-last-data-store expander doc 'function)) | 1688 | (setq semantic-grammar-eldoc-last-data (cons expander doc))) |
| 1688 | doc))) | 1689 | doc))) |
| 1689 | 1690 | ||
| 1690 | (define-mode-local-override semantic-idle-summary-current-symbol-info | 1691 | (define-mode-local-override semantic-idle-summary-current-symbol-info |
diff --git a/lisp/cedet/semantic/scope.el b/lisp/cedet/semantic/scope.el index 2c0dea20107..c56cbc3c126 100644 --- a/lisp/cedet/semantic/scope.el +++ b/lisp/cedet/semantic/scope.el | |||
| @@ -134,7 +134,7 @@ Saves scoping information between runs of the analyzer.") | |||
| 134 | "Get the current cached scope, and reset it." | 134 | "Get the current cached scope, and reset it." |
| 135 | (when semanticdb-current-table | 135 | (when semanticdb-current-table |
| 136 | (let ((co (semanticdb-cache-get semanticdb-current-table | 136 | (let ((co (semanticdb-cache-get semanticdb-current-table |
| 137 | semantic-scope-cache))) | 137 | 'semantic-scope-cache))) |
| 138 | (semantic-reset co)))) | 138 | (semantic-reset co)))) |
| 139 | 139 | ||
| 140 | (defmethod semantic-scope-set-typecache ((cache semantic-scope-cache) | 140 | (defmethod semantic-scope-set-typecache ((cache semantic-scope-cache) |
| @@ -706,7 +706,7 @@ The class returned from the scope calculation is variable | |||
| 706 | (let* ((TAG (semantic-current-tag)) | 706 | (let* ((TAG (semantic-current-tag)) |
| 707 | (scopecache | 707 | (scopecache |
| 708 | (semanticdb-cache-get semanticdb-current-table | 708 | (semanticdb-cache-get semanticdb-current-table |
| 709 | semantic-scope-cache)) | 709 | 'semantic-scope-cache)) |
| 710 | ) | 710 | ) |
| 711 | (when (not (semantic-equivalent-tag-p TAG (oref scopecache tag))) | 711 | (when (not (semantic-equivalent-tag-p TAG (oref scopecache tag))) |
| 712 | (semantic-reset scopecache)) | 712 | (semantic-reset scopecache)) |
diff --git a/lisp/cedet/srecode/compile.el b/lisp/cedet/srecode/compile.el index d899b42b1e1..782121ef5b5 100644 --- a/lisp/cedet/srecode/compile.el +++ b/lisp/cedet/srecode/compile.el | |||
| @@ -87,10 +87,10 @@ for push, pop, and peek for the active template.") | |||
| 87 | Useful if something goes wrong in SRecode, and the active template | 87 | Useful if something goes wrong in SRecode, and the active template |
| 88 | stack is broken." | 88 | stack is broken." |
| 89 | (interactive) | 89 | (interactive) |
| 90 | (if (oref srecode-template active) | 90 | (if (oref-default 'srecode-template active) |
| 91 | (when (y-or-n-p (format "%d active templates. Flush? " | 91 | (when (y-or-n-p (format "%d active templates. Flush? " |
| 92 | (length (oref srecode-template active)))) | 92 | (length (oref-default 'srecode-template active)))) |
| 93 | (oset-default srecode-template active nil)) | 93 | (oset-default 'srecode-template active nil)) |
| 94 | (message "No active templates to flush.")) | 94 | (message "No active templates to flush.")) |
| 95 | ) | 95 | ) |
| 96 | 96 | ||
| @@ -514,7 +514,7 @@ to the inserter constructor." | |||
| 514 | ;;(message "Compile: %s %S" name props) | 514 | ;;(message "Compile: %s %S" name props) |
| 515 | (if (not key) | 515 | (if (not key) |
| 516 | (apply 'srecode-template-inserter-variable name props) | 516 | (apply 'srecode-template-inserter-variable name props) |
| 517 | (let ((classes (eieio-class-children srecode-template-inserter)) | 517 | (let ((classes (eieio-class-children 'srecode-template-inserter)) |
| 518 | (new nil)) | 518 | (new nil)) |
| 519 | ;; Loop over the various subclasses and | 519 | ;; Loop over the various subclasses and |
| 520 | ;; create the correct inserter. | 520 | ;; create the correct inserter. |
diff --git a/lisp/cedet/srecode/fields.el b/lisp/cedet/srecode/fields.el index 20852f78b41..f473a0d8261 100644 --- a/lisp/cedet/srecode/fields.el +++ b/lisp/cedet/srecode/fields.el | |||
| @@ -237,7 +237,7 @@ If SET-TO is a string, then replace the text of OLAID wit SET-TO." | |||
| 237 | 237 | ||
| 238 | (defsubst srecode-active-template-region () | 238 | (defsubst srecode-active-template-region () |
| 239 | "Return the active region for template fields." | 239 | "Return the active region for template fields." |
| 240 | (oref srecode-template-inserted-region active-region)) | 240 | (oref-default 'srecode-template-inserted-region active-region)) |
| 241 | 241 | ||
| 242 | (defun srecode-field-post-command () | 242 | (defun srecode-field-post-command () |
| 243 | "Srecode field handler in the post command hook." | 243 | "Srecode field handler in the post command hook." |
diff --git a/lisp/cedet/srecode/insert.el b/lisp/cedet/srecode/insert.el index f1f23bc6f1d..78ec1658859 100644 --- a/lisp/cedet/srecode/insert.el +++ b/lisp/cedet/srecode/insert.el | |||
| @@ -211,7 +211,7 @@ insertions." | |||
| 211 | (propertize " (most recent at bottom)" 'face '(:slant italic)) | 211 | (propertize " (most recent at bottom)" 'face '(:slant italic)) |
| 212 | ":\n") | 212 | ":\n") |
| 213 | (data-debug-insert-stuff-list | 213 | (data-debug-insert-stuff-list |
| 214 | (reverse (oref srecode-template active)) "> ") | 214 | (reverse (oref-default 'srecode-template active)) "> ") |
| 215 | ;; Show the current dictionary. | 215 | ;; Show the current dictionary. |
| 216 | (insert (propertize "Dictionary" 'face '(:weight bold)) "\n") | 216 | (insert (propertize "Dictionary" 'face '(:weight bold)) "\n") |
| 217 | (data-debug-insert-thing dictionary "" "> ") | 217 | (data-debug-insert-thing dictionary "" "> ") |
| @@ -396,7 +396,7 @@ Specify the :blank argument to enable this inserter.") | |||
| 396 | (pm (point-marker))) | 396 | (pm (point-marker))) |
| 397 | (when (and inbuff | 397 | (when (and inbuff |
| 398 | ;; Don't do this if we are not the active template. | 398 | ;; Don't do this if we are not the active template. |
| 399 | (= (length (oref srecode-template active)) 1)) | 399 | (= (length (oref-default 'srecode-template active)) 1)) |
| 400 | 400 | ||
| 401 | (when (and (eq i t) inbuff (not (eq (oref sti where) 'begin))) | 401 | (when (and (eq i t) inbuff (not (eq (oref sti where) 'begin))) |
| 402 | (indent-according-to-mode) | 402 | (indent-according-to-mode) |
| @@ -773,7 +773,7 @@ generalized marker will do something else. See | |||
| 773 | ;; valid. Compare this to the actual template nesting depth and | 773 | ;; valid. Compare this to the actual template nesting depth and |
| 774 | ;; maybe use the override function which is stored in the cdr. | 774 | ;; maybe use the override function which is stored in the cdr. |
| 775 | (if (and srecode-template-inserter-point-override | 775 | (if (and srecode-template-inserter-point-override |
| 776 | (<= (length (oref srecode-template active)) | 776 | (<= (length (oref-default 'srecode-template active)) |
| 777 | (car srecode-template-inserter-point-override))) | 777 | (car srecode-template-inserter-point-override))) |
| 778 | ;; Disable the old override while we do this. | 778 | ;; Disable the old override while we do this. |
| 779 | (let ((over (cdr srecode-template-inserter-point-override)) | 779 | (let ((over (cdr srecode-template-inserter-point-override)) |
| @@ -943,7 +943,7 @@ this template instance." | |||
| 943 | ;; Calculate and store the discovered template | 943 | ;; Calculate and store the discovered template |
| 944 | (let ((tmpl (srecode-template-get-table (srecode-table) | 944 | (let ((tmpl (srecode-template-get-table (srecode-table) |
| 945 | templatenamepart)) | 945 | templatenamepart)) |
| 946 | (active (oref srecode-template active)) | 946 | (active (oref-default 'srecode-template active)) |
| 947 | ctxt) | 947 | ctxt) |
| 948 | (when (not tmpl) | 948 | (when (not tmpl) |
| 949 | ;; If it isn't just available, scan back through | 949 | ;; If it isn't just available, scan back through |
| @@ -1053,7 +1053,7 @@ template where a ^ inserter occurs." | |||
| 1053 | (lexical-let ((inserter1 sti)) | 1053 | (lexical-let ((inserter1 sti)) |
| 1054 | (cons | 1054 | (cons |
| 1055 | ;; DEPTH | 1055 | ;; DEPTH |
| 1056 | (+ (length (oref srecode-template active)) 1) | 1056 | (+ (length (oref-default 'srecode-template active)) 1) |
| 1057 | ;; FUNCTION | 1057 | ;; FUNCTION |
| 1058 | (lambda (dict) | 1058 | (lambda (dict) |
| 1059 | (let ((srecode-template-inserter-point-override nil)) | 1059 | (let ((srecode-template-inserter-point-override nil)) |
diff --git a/lisp/cedet/srecode/map.el b/lisp/cedet/srecode/map.el index 7224d5942f6..cc0c4ae4427 100644 --- a/lisp/cedet/srecode/map.el +++ b/lisp/cedet/srecode/map.el | |||
| @@ -298,7 +298,7 @@ if that file is NEW, otherwise assume the mode has not changed." | |||
| 298 | (when (not srecode-current-map) | 298 | (when (not srecode-current-map) |
| 299 | (condition-case nil | 299 | (condition-case nil |
| 300 | (setq srecode-current-map | 300 | (setq srecode-current-map |
| 301 | (eieio-persistent-read srecode-map-save-file srecode-map)) | 301 | (eieio-persistent-read srecode-map-save-file 'srecode-map)) |
| 302 | (error | 302 | (error |
| 303 | ;; There was an error loading the old map. Create a new one. | 303 | ;; There was an error loading the old map. Create a new one. |
| 304 | (setq srecode-current-map | 304 | (setq srecode-current-map |
diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index 62b2b5cc6da..851b3bfc6fd 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el | |||
| @@ -422,7 +422,7 @@ or is created with the bounds of SEQ." | |||
| 422 | (if (stringp (car (oref seq data))) | 422 | (if (stringp (car (oref seq data))) |
| 423 | (let ((labels (oref seq data))) | 423 | (let ((labels (oref seq data))) |
| 424 | (if (not axis) | 424 | (if (not axis) |
| 425 | (setq axis (make-instance chart-axis-names | 425 | (setq axis (make-instance 'chart-axis-names |
| 426 | :name (oref seq name) | 426 | :name (oref seq name) |
| 427 | :items labels | 427 | :items labels |
| 428 | :chart c)) | 428 | :chart c)) |
| @@ -430,7 +430,7 @@ or is created with the bounds of SEQ." | |||
| 430 | (let ((range (cons 0 1)) | 430 | (let ((range (cons 0 1)) |
| 431 | (l (oref seq data))) | 431 | (l (oref seq data))) |
| 432 | (if (not axis) | 432 | (if (not axis) |
| 433 | (setq axis (make-instance chart-axis-range | 433 | (setq axis (make-instance 'chart-axis-range |
| 434 | :name (oref seq name) | 434 | :name (oref seq name) |
| 435 | :chart c))) | 435 | :chart c))) |
| 436 | (while l | 436 | (while l |
| @@ -577,19 +577,19 @@ labeled NUMTITLE. | |||
| 577 | Optional arguments: | 577 | Optional arguments: |
| 578 | Set the chart's max element display to MAX, and sort lists with | 578 | Set the chart's max element display to MAX, and sort lists with |
| 579 | SORT-PRED if desired." | 579 | SORT-PRED if desired." |
| 580 | (let ((nc (make-instance chart-bar | 580 | (let ((nc (make-instance 'chart-bar |
| 581 | :title title | 581 | :title title |
| 582 | :key-label "8-m" ; This is a text key pic | 582 | :key-label "8-m" ; This is a text key pic |
| 583 | :direction dir | 583 | :direction dir |
| 584 | )) | 584 | )) |
| 585 | (iv (eq dir 'vertical))) | 585 | (iv (eq dir 'vertical))) |
| 586 | (chart-add-sequence nc | 586 | (chart-add-sequence nc |
| 587 | (make-instance chart-sequece | 587 | (make-instance 'chart-sequece |
| 588 | :data namelst | 588 | :data namelst |
| 589 | :name nametitle) | 589 | :name nametitle) |
| 590 | (if iv 'x-axis 'y-axis)) | 590 | (if iv 'x-axis 'y-axis)) |
| 591 | (chart-add-sequence nc | 591 | (chart-add-sequence nc |
| 592 | (make-instance chart-sequece | 592 | (make-instance 'chart-sequece |
| 593 | :data numlst | 593 | :data numlst |
| 594 | :name numtitle) | 594 | :name numtitle) |
| 595 | (if iv 'y-axis 'x-axis)) | 595 | (if iv 'y-axis 'x-axis)) |
diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 7478908051c..9931fbd114e 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el | |||
| @@ -40,7 +40,7 @@ | |||
| 40 | ;; error if a slot is unbound. | 40 | ;; error if a slot is unbound. |
| 41 | (defclass eieio-instance-inheritor () | 41 | (defclass eieio-instance-inheritor () |
| 42 | ((parent-instance :initarg :parent-instance | 42 | ((parent-instance :initarg :parent-instance |
| 43 | :type eieio-instance-inheritor-child | 43 | :type eieio-instance-inheritor |
| 44 | :documentation | 44 | :documentation |
| 45 | "The parent of this instance. | 45 | "The parent of this instance. |
| 46 | If a slot of this class is referenced, and is unbound, then the parent | 46 | 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." | |||
| 63 | ;; Throw the regular signal. | 63 | ;; Throw the regular signal. |
| 64 | (call-next-method))) | 64 | (call-next-method))) |
| 65 | 65 | ||
| 66 | (defmethod clone ((obj eieio-instance-inheritor) &rest params) | 66 | (defmethod clone ((obj eieio-instance-inheritor) &rest _params) |
| 67 | "Clone OBJ, initializing `:parent' to OBJ. | 67 | "Clone OBJ, initializing `:parent' to OBJ. |
| 68 | All slots are unbound, except those initialized with PARAMS." | 68 | All slots are unbound, except those initialized with PARAMS." |
| 69 | (let ((nobj (make-vector (length obj) eieio-unbound)) | 69 | (let ((nobj (call-next-method))) |
| 70 | (nm (eieio--object-name obj)) | ||
| 71 | (passname (and params (stringp (car params)))) | ||
| 72 | (num 1)) | ||
| 73 | (aset nobj 0 'object) | ||
| 74 | (setf (eieio--object-class nobj) (eieio--object-class obj)) | ||
| 75 | ;; The following was copied from the default clone. | ||
| 76 | (if (not passname) | ||
| 77 | (save-match-data | ||
| 78 | (if (string-match "-\\([0-9]+\\)" nm) | ||
| 79 | (setq num (1+ (string-to-number (match-string 1 nm))) | ||
| 80 | nm (substring nm 0 (match-beginning 0)))) | ||
| 81 | (setf (eieio--object-name nobj) (concat nm "-" (int-to-string num)))) | ||
| 82 | (setf (eieio--object-name nobj) (car params))) | ||
| 83 | ;; Now initialize from params. | ||
| 84 | (if params (shared-initialize nobj (if passname (cdr params) params))) | ||
| 85 | (oset nobj parent-instance obj) | 70 | (oset nobj parent-instance obj) |
| 86 | nobj)) | 71 | nobj)) |
| 87 | 72 | ||
| @@ -155,7 +140,7 @@ Multiple calls to `make-instance' will return this object.")) | |||
| 155 | A singleton is a class which will only ever have one instance." | 140 | A singleton is a class which will only ever have one instance." |
| 156 | :abstract t) | 141 | :abstract t) |
| 157 | 142 | ||
| 158 | (defmethod constructor :STATIC ((class eieio-singleton) _name &rest _slots) | 143 | (defmethod eieio-constructor :STATIC ((class eieio-singleton) &rest _slots) |
| 159 | "Constructor for singleton CLASS. | 144 | "Constructor for singleton CLASS. |
| 160 | NAME and SLOTS initialize the new object. | 145 | NAME and SLOTS initialize the new object. |
| 161 | This constructor guarantees that no matter how many you request, | 146 | This constructor guarantees that no matter how many you request, |
| @@ -270,7 +255,7 @@ malicious code. | |||
| 270 | Note: This function recurses when a slot of :type of some object is | 255 | Note: This function recurses when a slot of :type of some object is |
| 271 | identified, and needing more object creation." | 256 | identified, and needing more object creation." |
| 272 | (let ((objclass (nth 0 inputlist)) | 257 | (let ((objclass (nth 0 inputlist)) |
| 273 | (objname (nth 1 inputlist)) | 258 | ;; (objname (nth 1 inputlist)) |
| 274 | (slots (nthcdr 2 inputlist)) | 259 | (slots (nthcdr 2 inputlist)) |
| 275 | (createslots nil)) | 260 | (createslots nil)) |
| 276 | 261 | ||
| @@ -285,7 +270,7 @@ identified, and needing more object creation." | |||
| 285 | ;; In addition, strip out quotes, list functions, and update | 270 | ;; In addition, strip out quotes, list functions, and update |
| 286 | ;; object constructors as needed. | 271 | ;; object constructors as needed. |
| 287 | (setq value (eieio-persistent-validate/fix-slot-value | 272 | (setq value (eieio-persistent-validate/fix-slot-value |
| 288 | objclass name value)) | 273 | (eieio--class-v objclass) name value)) |
| 289 | 274 | ||
| 290 | (push name createslots) | 275 | (push name createslots) |
| 291 | (push value createslots) | 276 | (push value createslots) |
| @@ -293,7 +278,7 @@ identified, and needing more object creation." | |||
| 293 | 278 | ||
| 294 | (setq slots (cdr (cdr slots)))) | 279 | (setq slots (cdr (cdr slots)))) |
| 295 | 280 | ||
| 296 | (apply 'make-instance objclass objname (nreverse createslots)) | 281 | (apply #'make-instance objclass (nreverse createslots)) |
| 297 | 282 | ||
| 298 | ;;(eval inputlist) | 283 | ;;(eval inputlist) |
| 299 | )) | 284 | )) |
| @@ -305,11 +290,13 @@ constructor functions are considered valid. | |||
| 305 | Second, any text properties will be stripped from strings." | 290 | Second, any text properties will be stripped from strings." |
| 306 | (cond ((consp proposed-value) | 291 | (cond ((consp proposed-value) |
| 307 | ;; Lists with something in them need special treatment. | 292 | ;; Lists with something in them need special treatment. |
| 308 | (let ((slot-idx (eieio-slot-name-index class nil slot)) | 293 | (let ((slot-idx (eieio--slot-name-index class |
| 294 | nil slot)) | ||
| 309 | (type nil) | 295 | (type nil) |
| 310 | (classtype nil)) | 296 | (classtype nil)) |
| 311 | (setq slot-idx (- slot-idx 3)) | 297 | (setq slot-idx (- slot-idx |
| 312 | (setq type (aref (eieio--class-public-type (class-v class)) | 298 | (eval-when-compile eieio--object-num-slots))) |
| 299 | (setq type (aref (eieio--class-public-type class) | ||
| 313 | slot-idx)) | 300 | slot-idx)) |
| 314 | 301 | ||
| 315 | (setq classtype (eieio-persistent-slot-type-is-class-p | 302 | (setq classtype (eieio-persistent-slot-type-is-class-p |
| @@ -346,8 +333,8 @@ Second, any text properties will be stripped from strings." | |||
| 346 | (unless (and | 333 | (unless (and |
| 347 | ;; Do we have a type? | 334 | ;; Do we have a type? |
| 348 | (consp classtype) (class-p (car classtype))) | 335 | (consp classtype) (class-p (car classtype))) |
| 349 | (error "In save file, list of object constructors found, but no :type specified for slot %S" | 336 | (error "In save file, list of object constructors found, but no :type specified for slot %S of type %S" |
| 350 | slot)) | 337 | slot classtype)) |
| 351 | 338 | ||
| 352 | ;; We have a predicate, but it doesn't satisfy the predicate? | 339 | ;; We have a predicate, but it doesn't satisfy the predicate? |
| 353 | (dolist (PV (cdr proposed-value)) | 340 | (dolist (PV (cdr proposed-value)) |
| @@ -375,31 +362,49 @@ Second, any text properties will be stripped from strings." | |||
| 375 | ) | 362 | ) |
| 376 | 363 | ||
| 377 | (defun eieio-persistent-slot-type-is-class-p (type) | 364 | (defun eieio-persistent-slot-type-is-class-p (type) |
| 378 | "Return the class refered to in TYPE. | 365 | "Return the class referred to in TYPE. |
| 379 | If no class is referenced there, then return nil." | 366 | If no class is referenced there, then return nil." |
| 380 | (cond ((class-p type) | 367 | (cond ((class-p type) |
| 381 | ;; If the type is a class, then return it. | 368 | ;; If the type is a class, then return it. |
| 382 | type) | 369 | type) |
| 383 | 370 | ((and (eq 'list-of (car-safe type)) (class-p (cadr type))) | |
| 384 | ((and (symbolp type) (string-match "-child$" (symbol-name type)) | 371 | ;; If it is the type of a list of a class, then return that class and |
| 372 | ;; the type. | ||
| 373 | (cons (cadr type) type)) | ||
| 374 | |||
| 375 | ((and (symbolp type) (get type 'cl-deftype-handler)) | ||
| 376 | ;; Macro-expand the type according to cl-deftype definitions. | ||
| 377 | (eieio-persistent-slot-type-is-class-p | ||
| 378 | (funcall (get type 'cl-deftype-handler)))) | ||
| 379 | |||
| 380 | ;; FIXME: foo-child should not be a valid type! | ||
| 381 | ((and (symbolp type) (string-match "-child\\'" (symbol-name type)) | ||
| 385 | (class-p (intern-soft (substring (symbol-name type) 0 | 382 | (class-p (intern-soft (substring (symbol-name type) 0 |
| 386 | (match-beginning 0))))) | 383 | (match-beginning 0))))) |
| 384 | (unless eieio-backward-compatibility | ||
| 385 | (error "Use of bogus %S type instead of %S" | ||
| 386 | type (intern-soft (substring (symbol-name type) 0 | ||
| 387 | (match-beginning 0))))) | ||
| 387 | ;; If it is the predicate ending with -child, then return | 388 | ;; If it is the predicate ending with -child, then return |
| 388 | ;; that class. Unfortunately, in EIEIO, typep of just the | 389 | ;; that class. Unfortunately, in EIEIO, typep of just the |
| 389 | ;; class is the same as if we used -child, so no further work needed. | 390 | ;; class is the same as if we used -child, so no further work needed. |
| 390 | (intern-soft (substring (symbol-name type) 0 | 391 | (intern-soft (substring (symbol-name type) 0 |
| 391 | (match-beginning 0)))) | 392 | (match-beginning 0)))) |
| 392 | 393 | ;; FIXME: foo-list should not be a valid type! | |
| 393 | ((and (symbolp type) (string-match "-list$" (symbol-name type)) | 394 | ((and (symbolp type) (string-match "-list\\'" (symbol-name type)) |
| 394 | (class-p (intern-soft (substring (symbol-name type) 0 | 395 | (class-p (intern-soft (substring (symbol-name type) 0 |
| 395 | (match-beginning 0))))) | 396 | (match-beginning 0))))) |
| 397 | (unless eieio-backward-compatibility | ||
| 398 | (error "Use of bogus %S type instead of (list-of %S)" | ||
| 399 | type (intern-soft (substring (symbol-name type) 0 | ||
| 400 | (match-beginning 0))))) | ||
| 396 | ;; If it is the predicate ending with -list, then return | 401 | ;; If it is the predicate ending with -list, then return |
| 397 | ;; that class and the predicate to use. | 402 | ;; that class and the predicate to use. |
| 398 | (cons (intern-soft (substring (symbol-name type) 0 | 403 | (cons (intern-soft (substring (symbol-name type) 0 |
| 399 | (match-beginning 0))) | 404 | (match-beginning 0))) |
| 400 | type)) | 405 | type)) |
| 401 | 406 | ||
| 402 | ((and (consp type) (eq (car type) 'or)) | 407 | ((eq (car-safe type) 'or) |
| 403 | ;; If type is a list, and is an or, it is possibly something | 408 | ;; If type is a list, and is an or, it is possibly something |
| 404 | ;; like (or null myclass), so check for that. | 409 | ;; like (or null myclass), so check for that. |
| 405 | (let ((ans nil)) | 410 | (let ((ans nil)) |
| @@ -463,34 +468,38 @@ instance." | |||
| 463 | 468 | ||
| 464 | 469 | ||
| 465 | ;;; Named object | 470 | ;;; Named object |
| 466 | ;; | ||
| 467 | ;; Named objects use the objects `name' as a slot, and that slot | ||
| 468 | ;; is accessed with the `object-name' symbol. | ||
| 469 | 471 | ||
| 470 | (defclass eieio-named () | 472 | (defclass eieio-named () |
| 471 | () | 473 | ((object-name :initarg :object-name :initform nil)) |
| 472 | "Object with a name. | 474 | "Object with a name." |
| 473 | Name storage already occurs in an object. This object provides get/set | ||
| 474 | access to it." | ||
| 475 | :abstract t) | 475 | :abstract t) |
| 476 | 476 | ||
| 477 | (defmethod slot-missing ((obj eieio-named) | 477 | (defmethod eieio-object-name-string ((obj eieio-named)) |
| 478 | slot-name operation &optional new-value) | 478 | "Return a string which is OBJ's name." |
| 479 | "Called when a non-existent slot is accessed. | 479 | (or (slot-value obj 'object-name) |
| 480 | For variable `eieio-named', provide an imaginary `object-name' slot. | 480 | (symbol-name (eieio-object-class obj)))) |
| 481 | Argument OBJ is the named object. | 481 | |
| 482 | Argument SLOT-NAME is the slot that was attempted to be accessed. | 482 | (defmethod eieio-object-set-name-string ((obj eieio-named) name) |
| 483 | OPERATION is the type of access, such as `oref' or `oset'. | 483 | "Set the string which is OBJ's NAME." |
| 484 | NEW-VALUE is the value that was being set into SLOT if OPERATION were | 484 | (eieio--check-type stringp name) |
| 485 | a set type." | 485 | (eieio-oset obj 'object-name name)) |
| 486 | (if (memq slot-name '(object-name :object-name)) | 486 | |
| 487 | (cond ((eq operation 'oset) | 487 | (defmethod clone ((obj eieio-named) &rest params) |
| 488 | (if (not (stringp new-value)) | 488 | "Clone OBJ, initializing `:parent' to OBJ. |
| 489 | (signal 'invalid-slot-type | 489 | All slots are unbound, except those initialized with PARAMS." |
| 490 | (list obj slot-name 'string new-value))) | 490 | (let* ((newname (and (stringp (car params)) (pop params))) |
| 491 | (eieio-object-set-name-string obj new-value)) | 491 | (nobj (apply #'call-next-method obj params)) |
| 492 | (t (eieio-object-name-string obj))) | 492 | (nm (slot-value obj 'object-name))) |
| 493 | (call-next-method))) | 493 | (eieio-oset obj 'object-name |
| 494 | (or newname | ||
| 495 | (save-match-data | ||
| 496 | (if (and nm (string-match "-\\([0-9]+\\)" nm)) | ||
| 497 | (let ((num (1+ (string-to-number | ||
| 498 | (match-string 1 nm))))) | ||
| 499 | (concat (substring nm 0 (match-beginning 0)) | ||
| 500 | "-" (int-to-string num))) | ||
| 501 | (concat nm "-1"))))) | ||
| 502 | nobj)) | ||
| 494 | 503 | ||
| 495 | (provide 'eieio-base) | 504 | (provide 'eieio-base) |
| 496 | 505 | ||
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 68b376592f5..dc2c873eb42 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el | |||
| @@ -32,6 +32,7 @@ | |||
| 32 | ;;; Code: | 32 | ;;; Code: |
| 33 | 33 | ||
| 34 | (require 'cl-lib) | 34 | (require 'cl-lib) |
| 35 | (require 'pcase) | ||
| 35 | 36 | ||
| 36 | (put 'eieio--defalias 'byte-hunk-handler | 37 | (put 'eieio--defalias 'byte-hunk-handler |
| 37 | #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) | 38 | #'byte-compile-file-form-defalias) ;;(get 'defalias 'byte-hunk-handler) |
| @@ -39,6 +40,9 @@ | |||
| 39 | "Like `defalias', but with less side-effects. | 40 | "Like `defalias', but with less side-effects. |
| 40 | More specifically, it has no side-effects at all when the new function | 41 | More specifically, it has no side-effects at all when the new function |
| 41 | definition is the same (`eq') as the old one." | 42 | definition is the same (`eq') as the old one." |
| 43 | (while (and (fboundp name) (symbolp (symbol-function name))) | ||
| 44 | ;; Follow aliases, so methods applied to obsolete aliases still work. | ||
| 45 | (setq name (symbol-function name))) | ||
| 42 | (unless (and (fboundp name) | 46 | (unless (and (fboundp name) |
| 43 | (eq (symbol-function name) body)) | 47 | (eq (symbol-function name) body)) |
| 44 | (defalias name body))) | 48 | (defalias name body))) |
| @@ -74,6 +78,13 @@ default setting for optimization purposes.") | |||
| 74 | (defvar eieio-initializing-object nil | 78 | (defvar eieio-initializing-object nil |
| 75 | "Set to non-nil while initializing an object.") | 79 | "Set to non-nil while initializing an object.") |
| 76 | 80 | ||
| 81 | (defvar eieio-backward-compatibility t | ||
| 82 | "If nil, drop support for some behaviors of older versions of EIEIO. | ||
| 83 | Currently under control of this var: | ||
| 84 | - Define every class as a var whose value is the class symbol. | ||
| 85 | - Define <class>-child-p and <class>-list-p predicates. | ||
| 86 | - Allow object names in constructors.") | ||
| 87 | |||
| 77 | (defconst eieio-unbound | 88 | (defconst eieio-unbound |
| 78 | (if (and (boundp 'eieio-unbound) (symbolp eieio-unbound)) | 89 | (if (and (boundp 'eieio-unbound) (symbolp eieio-unbound)) |
| 79 | eieio-unbound | 90 | eieio-unbound |
| @@ -98,96 +109,87 @@ default setting for optimization purposes.") | |||
| 98 | "A stack of the classes currently in scope during method invocation.") | 109 | "A stack of the classes currently in scope during method invocation.") |
| 99 | 110 | ||
| 100 | (defun eieio--scoped-class () | 111 | (defun eieio--scoped-class () |
| 101 | "Return the class currently in scope, or nil." | 112 | "Return the class object currently in scope, or nil." |
| 102 | (car-safe eieio--scoped-class-stack)) | 113 | (car-safe eieio--scoped-class-stack)) |
| 103 | 114 | ||
| 104 | (defmacro eieio--with-scoped-class (class &rest forms) | 115 | (defmacro eieio--with-scoped-class (class &rest forms) |
| 105 | "Set CLASS as the currently scoped class while executing FORMS." | 116 | "Set CLASS as the currently scoped class while executing FORMS." |
| 106 | (declare (indent 1)) | 117 | (declare (indent 1)) |
| 107 | `(unwind-protect | 118 | `(let ((eieio--scoped-class-stack (cons ,class eieio--scoped-class-stack))) |
| 108 | (progn | 119 | ,@forms)) |
| 109 | (push ,class eieio--scoped-class-stack) | 120 | |
| 110 | ,@forms) | 121 | (progn |
| 111 | (pop eieio--scoped-class-stack))) | 122 | ;; Arrange for field access not to bother checking if the access is indeed |
| 123 | ;; made to an eieio--class object. | ||
| 124 | (cl-declaim (optimize (safety 0))) | ||
| 125 | (cl-defstruct (eieio--class | ||
| 126 | (:constructor nil) | ||
| 127 | (:constructor eieio--class-make (symbol &aux (tag 'defclass))) | ||
| 128 | (:type vector) | ||
| 129 | (:copier nil)) | ||
| 130 | ;; We use an untagged cl-struct, with our own hand-made tag as first field | ||
| 131 | ;; (containing the symbol `defclass'). It would be better to use a normal | ||
| 132 | ;; cl-struct with its normal tag (e.g. so that cl-defstruct can define the | ||
| 133 | ;; predicate for us), but that breaks compatibility with .elc files compiled | ||
| 134 | ;; against older versions of EIEIO. | ||
| 135 | tag | ||
| 136 | symbol ;; symbol (self-referencing) | ||
| 137 | parent children | ||
| 138 | symbol-hashtable ;; hashtable permitting fast access to variable position indexes | ||
| 139 | ;; @todo | ||
| 140 | ;; the word "public" here is leftovers from the very first version. | ||
| 141 | ;; Get rid of it! | ||
| 142 | public-a ;; class attribute index | ||
| 143 | public-d ;; class attribute defaults index | ||
| 144 | public-doc ;; class documentation strings for attributes | ||
| 145 | public-type ;; class type for a slot | ||
| 146 | public-custom ;; class custom type for a slot | ||
| 147 | public-custom-label ;; class custom group for a slot | ||
| 148 | public-custom-group ;; class custom group for a slot | ||
| 149 | public-printer ;; printer for a slot | ||
| 150 | protection ;; protection for a slot | ||
| 151 | initarg-tuples ;; initarg tuples list | ||
| 152 | class-allocation-a ;; class allocated attributes | ||
| 153 | class-allocation-doc ;; class allocated documentation | ||
| 154 | class-allocation-type ;; class allocated value type | ||
| 155 | class-allocation-custom ;; class allocated custom descriptor | ||
| 156 | class-allocation-custom-label ;; class allocated custom descriptor | ||
| 157 | class-allocation-custom-group ;; class allocated custom group | ||
| 158 | class-allocation-printer ;; class allocated printer for a slot | ||
| 159 | class-allocation-protection ;; class allocated protection list | ||
| 160 | class-allocation-values ;; class allocated value vector | ||
| 161 | default-object-cache ;; what a newly created object would look like. | ||
| 162 | ; This will speed up instantiation time as | ||
| 163 | ; only a `copy-sequence' will be needed, instead of | ||
| 164 | ; looping over all the values and setting them from | ||
| 165 | ; the default. | ||
| 166 | options ;; storage location of tagged class option | ||
| 167 | ; Stored outright without modifications or stripping | ||
| 168 | ) | ||
| 169 | ;; Set it back to the default value. | ||
| 170 | (cl-declaim (optimize (safety 1)))) | ||
| 112 | 171 | ||
| 113 | ;;; | 172 | |
| 114 | ;; Field Accessors | 173 | (cl-defstruct (eieio--object |
| 115 | ;; | 174 | (:type vector) ;We manage our own tagging system. |
| 116 | (defmacro eieio--define-field-accessors (prefix fields) | 175 | (:constructor nil) |
| 117 | (declare (indent 1)) | 176 | (:copier nil)) |
| 118 | (let ((index 0) | 177 | ;; `class-tag' holds a symbol, which is not the class name, but is instead |
| 119 | (defs '())) | 178 | ;; properly prefixed as an internal EIEIO thingy and which holds the class |
| 120 | (dolist (field fields) | 179 | ;; object/struct in its `symbol-value' slot. |
| 121 | (let ((doc (if (listp field) | 180 | class-tag) |
| 122 | (prog1 (cadr field) (setq field (car field)))))) | 181 | |
| 123 | (push `(defmacro ,(intern (format "eieio--%s-%s" prefix field)) (x) | 182 | (eval-and-compile |
| 124 | ,@(if doc (list (format (if (string-match "\n" doc) | 183 | (defconst eieio--object-num-slots |
| 125 | "Return %s" "Return %s of a %s.") | 184 | (length (get 'eieio--object 'cl-struct-slots)))) |
| 126 | doc prefix))) | 185 | |
| 127 | (list 'aref x ,index)) | 186 | (defsubst eieio--object-class-object (obj) |
| 128 | defs) | 187 | (symbol-value (eieio--object-class-tag obj))) |
| 129 | (setq index (1+ index)))) | 188 | |
| 130 | `(eval-and-compile | 189 | (defsubst eieio--object-class-name (obj) |
| 131 | ,@(nreverse defs) | 190 | ;; FIXME: Most uses of this function should be changed to use |
| 132 | (defconst ,(intern (format "eieio--%s-num-slots" prefix)) ,index)))) | 191 | ;; eieio--object-class-object instead! |
| 133 | 192 | (eieio--class-symbol (eieio--object-class-object obj))) | |
| 134 | (eieio--define-field-accessors class | ||
| 135 | (-unused-0 ;;FIXME: not sure, but at least there was no accessor! | ||
| 136 | (symbol "symbol (self-referencing)") | ||
| 137 | parent children | ||
| 138 | (symbol-obarray "obarray permitting fast access to variable position indexes") | ||
| 139 | ;; @todo | ||
| 140 | ;; the word "public" here is leftovers from the very first version. | ||
| 141 | ;; Get rid of it! | ||
| 142 | (public-a "class attribute index") | ||
| 143 | (public-d "class attribute defaults index") | ||
| 144 | (public-doc "class documentation strings for attributes") | ||
| 145 | (public-type "class type for a slot") | ||
| 146 | (public-custom "class custom type for a slot") | ||
| 147 | (public-custom-label "class custom group for a slot") | ||
| 148 | (public-custom-group "class custom group for a slot") | ||
| 149 | (public-printer "printer for a slot") | ||
| 150 | (protection "protection for a slot") | ||
| 151 | (initarg-tuples "initarg tuples list") | ||
| 152 | (class-allocation-a "class allocated attributes") | ||
| 153 | (class-allocation-doc "class allocated documentation") | ||
| 154 | (class-allocation-type "class allocated value type") | ||
| 155 | (class-allocation-custom "class allocated custom descriptor") | ||
| 156 | (class-allocation-custom-label "class allocated custom descriptor") | ||
| 157 | (class-allocation-custom-group "class allocated custom group") | ||
| 158 | (class-allocation-printer "class allocated printer for a slot") | ||
| 159 | (class-allocation-protection "class allocated protection list") | ||
| 160 | (class-allocation-values "class allocated value vector") | ||
| 161 | (default-object-cache "what a newly created object would look like. | ||
| 162 | This will speed up instantiation time as only a `copy-sequence' will | ||
| 163 | be needed, instead of looping over all the values and setting them | ||
| 164 | from the default.") | ||
| 165 | (options "storage location of tagged class options. | ||
| 166 | Stored outright without modifications or stripping."))) | ||
| 167 | |||
| 168 | (eieio--define-field-accessors object | ||
| 169 | (-unused-0 ;;FIXME: not sure, but at least there was no accessor! | ||
| 170 | (class "class struct defining OBJ") | ||
| 171 | name)) | ||
| 172 | |||
| 173 | ;; FIXME: The constants below should have an `eieio-' prefix added!! | ||
| 174 | |||
| 175 | (defconst method-static 0 "Index into :static tag on a method.") | ||
| 176 | (defconst method-before 1 "Index into :before tag on a method.") | ||
| 177 | (defconst method-primary 2 "Index into :primary tag on a method.") | ||
| 178 | (defconst method-after 3 "Index into :after tag on a method.") | ||
| 179 | (defconst method-num-lists 4 "Number of indexes into methods vector in which groups of functions are kept.") | ||
| 180 | (defconst method-generic-before 4 "Index into generic :before tag on a method.") | ||
| 181 | (defconst method-generic-primary 5 "Index into generic :primary tag on a method.") | ||
| 182 | (defconst method-generic-after 6 "Index into generic :after tag on a method.") | ||
| 183 | (defconst method-num-slots 7 "Number of indexes into a method's vector.") | ||
| 184 | |||
| 185 | (defsubst eieio-specialized-key-to-generic-key (key) | ||
| 186 | "Convert a specialized KEY into a generic method key." | ||
| 187 | (cond ((eq key method-static) 0) ;; don't convert | ||
| 188 | ((< key method-num-lists) (+ key 3)) ;; The conversion | ||
| 189 | (t key) ;; already generic.. maybe. | ||
| 190 | )) | ||
| 191 | 193 | ||
| 192 | 194 | ||
| 193 | ;;; Important macros used internally in eieio. | 195 | ;;; Important macros used internally in eieio. |
| @@ -201,114 +203,91 @@ Stored outright without modifications or stripping."))) | |||
| 201 | (t `(,type ,obj)))) | 203 | (t `(,type ,obj)))) |
| 202 | (signal 'wrong-type-argument (list ',type ,obj)))) | 204 | (signal 'wrong-type-argument (list ',type ,obj)))) |
| 203 | 205 | ||
| 204 | (defmacro class-v (class) | 206 | (defmacro eieio--class-v (class) ;Use a macro, so it acts as a GV place. |
| 205 | "Internal: Return the class vector from the CLASS symbol." | 207 | "Internal: Return the class vector from the CLASS symbol." |
| 208 | (declare (debug t)) | ||
| 206 | ;; No check: If eieio gets this far, it has probably been checked already. | 209 | ;; No check: If eieio gets this far, it has probably been checked already. |
| 207 | `(get ,class 'eieio-class-definition)) | 210 | `(get ,class 'eieio-class-definition)) |
| 208 | 211 | ||
| 212 | (defsubst eieio--class-object (class) | ||
| 213 | "Return the class object." | ||
| 214 | (if (symbolp class) | ||
| 215 | ;; Keep the symbol if class-v is nil, for better error messages. | ||
| 216 | (or (eieio--class-v class) class) | ||
| 217 | class)) | ||
| 218 | |||
| 219 | (defsubst eieio--class-p (class) | ||
| 220 | "Return non-nil if CLASS is a valid class object." | ||
| 221 | (condition-case nil | ||
| 222 | (eq (aref class 0) 'defclass) | ||
| 223 | (error nil))) | ||
| 224 | |||
| 225 | (defsubst eieio-class-object (class) | ||
| 226 | "Check that CLASS is a class and return the corresponding object." | ||
| 227 | (let ((c (eieio--class-object class))) | ||
| 228 | (eieio--check-type eieio--class-p c) | ||
| 229 | c)) | ||
| 230 | |||
| 209 | (defsubst class-p (class) | 231 | (defsubst class-p (class) |
| 210 | "Return non-nil if CLASS is a valid class vector. | 232 | "Return non-nil if CLASS is a valid class vector. |
| 211 | CLASS is a symbol." | 233 | CLASS is a symbol." ;FIXME: Is it a vector or a symbol? |
| 212 | ;; this new method is faster since it doesn't waste time checking lots of | 234 | ;; this new method is faster since it doesn't waste time checking lots of |
| 213 | ;; things. | 235 | ;; things. |
| 214 | (condition-case nil | 236 | (condition-case nil |
| 215 | (eq (aref (class-v class) 0) 'defclass) | 237 | (eq (aref (eieio--class-v class) 0) 'defclass) |
| 216 | (error nil))) | 238 | (error nil))) |
| 217 | 239 | ||
| 218 | (defun eieio-class-name (class) "Return a Lisp like symbol name for CLASS." | 240 | (defun eieio-class-name (class) |
| 241 | "Return a Lisp like symbol name for CLASS." | ||
| 242 | ;; FIXME: What's a "Lisp like symbol name"? | ||
| 243 | ;; FIXME: CLOS returns a symbol, but the code returns a string. | ||
| 244 | (if (eieio--class-p class) (setq class (eieio--class-symbol class))) | ||
| 219 | (eieio--check-type class-p class) | 245 | (eieio--check-type class-p class) |
| 220 | ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, | 246 | ;; I think this is supposed to return a symbol, but to me CLASS is a symbol, |
| 221 | ;; and I wanted a string. Arg! | 247 | ;; and I wanted a string. Arg! |
| 222 | (format "#<class %s>" (symbol-name class))) | 248 | (format "#<class %s>" (symbol-name class))) |
| 223 | (define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") | 249 | (define-obsolete-function-alias 'class-name #'eieio-class-name "24.4") |
| 224 | 250 | ||
| 225 | (defmacro eieio-class-parents-fast (class) | ||
| 226 | "Return parent classes to CLASS with no check." | ||
| 227 | `(eieio--class-parent (class-v ,class))) | ||
| 228 | |||
| 229 | (defmacro eieio-class-children-fast (class) "Return child classes to CLASS with no check." | ||
| 230 | `(eieio--class-children (class-v ,class))) | ||
| 231 | |||
| 232 | (defmacro same-class-fast-p (obj class) | ||
| 233 | "Return t if OBJ is of class-type CLASS with no error checking." | ||
| 234 | `(eq (eieio--object-class ,obj) ,class)) | ||
| 235 | |||
| 236 | (defmacro class-constructor (class) | 251 | (defmacro class-constructor (class) |
| 237 | "Return the symbol representing the constructor of CLASS." | 252 | "Return the symbol representing the constructor of CLASS." |
| 238 | `(eieio--class-symbol (class-v ,class))) | 253 | (declare (debug t)) |
| 239 | 254 | `(eieio--class-symbol (eieio--class-v ,class))) | |
| 240 | (defsubst generic-p (method) | 255 | |
| 241 | "Return non-nil if symbol METHOD is a generic function. | 256 | (defmacro eieio--class-option-assoc (list option) |
| 242 | Only methods have the symbol `eieio-method-obarray' as a property | ||
| 243 | \(which contains a list of all bindings to that method type.)" | ||
| 244 | (and (fboundp method) (get method 'eieio-method-obarray))) | ||
| 245 | |||
| 246 | (defun generic-primary-only-p (method) | ||
| 247 | "Return t if symbol METHOD is a generic function with only primary methods. | ||
| 248 | Only methods have the symbol `eieio-method-obarray' as a property (which | ||
| 249 | contains a list of all bindings to that method type.) | ||
| 250 | Methods with only primary implementations are executed in an optimized way." | ||
| 251 | (and (generic-p method) | ||
| 252 | (let ((M (get method 'eieio-method-tree))) | ||
| 253 | (and (< 0 (length (aref M method-primary))) | ||
| 254 | (not (aref M method-static)) | ||
| 255 | (not (aref M method-before)) | ||
| 256 | (not (aref M method-after)) | ||
| 257 | (not (aref M method-generic-before)) | ||
| 258 | (not (aref M method-generic-primary)) | ||
| 259 | (not (aref M method-generic-after)))) | ||
| 260 | )) | ||
| 261 | |||
| 262 | (defun generic-primary-only-one-p (method) | ||
| 263 | "Return t if symbol METHOD is a generic function with only primary methods. | ||
| 264 | Only methods have the symbol `eieio-method-obarray' as a property (which | ||
| 265 | contains a list of all bindings to that method type.) | ||
| 266 | Methods with only primary implementations are executed in an optimized way." | ||
| 267 | (and (generic-p method) | ||
| 268 | (let ((M (get method 'eieio-method-tree))) | ||
| 269 | (and (= 1 (length (aref M method-primary))) | ||
| 270 | (not (aref M method-static)) | ||
| 271 | (not (aref M method-before)) | ||
| 272 | (not (aref M method-after)) | ||
| 273 | (not (aref M method-generic-before)) | ||
| 274 | (not (aref M method-generic-primary)) | ||
| 275 | (not (aref M method-generic-after)))) | ||
| 276 | )) | ||
| 277 | |||
| 278 | (defmacro class-option-assoc (list option) | ||
| 279 | "Return from LIST the found OPTION, or nil if it doesn't exist." | 257 | "Return from LIST the found OPTION, or nil if it doesn't exist." |
| 280 | `(car-safe (cdr (memq ,option ,list)))) | 258 | `(car-safe (cdr (memq ,option ,list)))) |
| 281 | 259 | ||
| 282 | (defmacro class-option (class option) | 260 | (defsubst eieio--class-option (class option) |
| 283 | "Return the value stored for CLASS' OPTION. | 261 | "Return the value stored for CLASS' OPTION. |
| 284 | Return nil if that option doesn't exist." | 262 | Return nil if that option doesn't exist." |
| 285 | `(class-option-assoc (eieio--class-options (class-v ,class)) ',option)) | 263 | (eieio--class-option-assoc (eieio--class-options class) option)) |
| 286 | 264 | ||
| 287 | (defsubst eieio-object-p (obj) | 265 | (defsubst eieio-object-p (obj) |
| 288 | "Return non-nil if OBJ is an EIEIO object." | 266 | "Return non-nil if OBJ is an EIEIO object." |
| 289 | (condition-case nil | 267 | (and (arrayp obj) |
| 290 | (and (eq (aref obj 0) 'object) | 268 | (condition-case nil |
| 291 | (class-p (eieio--object-class obj))) | 269 | (eq (aref (eieio--object-class-object obj) 0) 'defclass) |
| 292 | (error nil))) | 270 | (error nil)))) |
| 271 | |||
| 293 | (defalias 'object-p 'eieio-object-p) | 272 | (defalias 'object-p 'eieio-object-p) |
| 294 | 273 | ||
| 295 | (defsubst class-abstract-p (class) | 274 | (defsubst class-abstract-p (class) |
| 296 | "Return non-nil if CLASS is abstract. | 275 | "Return non-nil if CLASS is abstract. |
| 297 | Abstract classes cannot be instantiated." | 276 | Abstract classes cannot be instantiated." |
| 298 | (class-option class :abstract)) | 277 | (eieio--class-option (eieio--class-v class) :abstract)) |
| 299 | 278 | ||
| 300 | (defmacro class-method-invocation-order (class) | 279 | (defsubst eieio--class-method-invocation-order (class) |
| 301 | "Return the invocation order of CLASS. | 280 | "Return the invocation order of CLASS. |
| 302 | Abstract classes cannot be instantiated." | 281 | Abstract classes cannot be instantiated." |
| 303 | `(or (class-option ,class :method-invocation-order) | 282 | (or (eieio--class-option class :method-invocation-order) |
| 304 | :breadth-first)) | 283 | :breadth-first)) |
| 305 | 284 | ||
| 306 | 285 | ||
| 307 | 286 | ||
| 308 | ;;; | 287 | ;;; |
| 309 | ;; Class Creation | 288 | ;; Class Creation |
| 310 | 289 | ||
| 311 | (defvar eieio-defclass-autoload-map (make-vector 7 nil) | 290 | (defvar eieio-defclass-autoload-map (make-hash-table) |
| 312 | "Symbol map of superclasses we find in autoloads.") | 291 | "Symbol map of superclasses we find in autoloads.") |
| 313 | 292 | ||
| 314 | ;; We autoload this because it's used in `make-autoload'. | 293 | ;; We autoload this because it's used in `make-autoload'. |
| @@ -322,16 +301,12 @@ SUPERCLASSES as children. | |||
| 322 | It creates an autoload function for CNAME's constructor." | 301 | It creates an autoload function for CNAME's constructor." |
| 323 | ;; Assume we've already debugged inputs. | 302 | ;; Assume we've already debugged inputs. |
| 324 | 303 | ||
| 325 | (let* ((oldc (when (class-p cname) (class-v cname))) | 304 | (let* ((oldc (when (class-p cname) (eieio--class-v cname))) |
| 326 | (newc (make-vector eieio--class-num-slots nil)) | 305 | (newc (eieio--class-make cname)) |
| 327 | ) | 306 | ) |
| 328 | (if oldc | 307 | (if oldc |
| 329 | nil ;; Do nothing if we already have this class. | 308 | nil ;; Do nothing if we already have this class. |
| 330 | 309 | ||
| 331 | ;; Create the class in NEWC, but don't fill anything else in. | ||
| 332 | (aset newc 0 'defclass) | ||
| 333 | (setf (eieio--class-symbol newc) cname) | ||
| 334 | |||
| 335 | (let ((clear-parent nil)) | 310 | (let ((clear-parent nil)) |
| 336 | ;; No parents? | 311 | ;; No parents? |
| 337 | (when (not superclasses) | 312 | (when (not superclasses) |
| @@ -348,34 +323,25 @@ It creates an autoload function for CNAME's constructor." | |||
| 348 | ;; map needs to be cleared! | 323 | ;; map needs to be cleared! |
| 349 | 324 | ||
| 350 | 325 | ||
| 351 | ;; Does our parent exist? | 326 | ;; Save the child in the parent. |
| 352 | (if (not (class-p SC)) | 327 | (cl-pushnew cname (if (class-p SC) |
| 353 | 328 | (eieio--class-children (eieio--class-v SC)) | |
| 354 | ;; Create a symbol for this parent, and then store this | 329 | ;; Parent doesn't exist yet. |
| 355 | ;; parent on that symbol. | 330 | (gethash SC eieio-defclass-autoload-map))) |
| 356 | (let ((sym (intern (symbol-name SC) eieio-defclass-autoload-map))) | ||
| 357 | (if (not (boundp sym)) | ||
| 358 | (set sym (list cname)) | ||
| 359 | (add-to-list sym cname)) | ||
| 360 | ) | ||
| 361 | 331 | ||
| 362 | ;; We have a parent, save the child in there. | 332 | ;; Save parent in child. |
| 363 | (when (not (member cname (eieio--class-children (class-v SC)))) | 333 | (push (eieio--class-v SC) (eieio--class-parent newc))) |
| 364 | (setf (eieio--class-children (class-v SC)) | ||
| 365 | (cons cname (eieio--class-children (class-v SC)))))) | ||
| 366 | |||
| 367 | ;; save parent in child | ||
| 368 | (setf (eieio--class-parent newc) (cons SC (eieio--class-parent newc))) | ||
| 369 | ) | ||
| 370 | 334 | ||
| 371 | ;; turn this into a usable self-pointing symbol | 335 | ;; turn this into a usable self-pointing symbol |
| 372 | (set cname cname) | 336 | (when eieio-backward-compatibility |
| 337 | (set cname cname) | ||
| 338 | (make-obsolete-variable cname (format "use '%s instead" cname) "25.1")) | ||
| 373 | 339 | ||
| 374 | ;; Store the new class vector definition into the symbol. We need to | 340 | ;; Store the new class vector definition into the symbol. We need to |
| 375 | ;; do this first so that we can call defmethod for the accessor. | 341 | ;; do this first so that we can call defmethod for the accessor. |
| 376 | ;; The vector will be updated by the following while loop and will not | 342 | ;; The vector will be updated by the following while loop and will not |
| 377 | ;; need to be stored a second time. | 343 | ;; need to be stored a second time. |
| 378 | (put cname 'eieio-class-definition newc) | 344 | (setf (eieio--class-v cname) newc) |
| 379 | 345 | ||
| 380 | ;; Clear the parent | 346 | ;; Clear the parent |
| 381 | (if clear-parent (setf (eieio--class-parent newc) nil)) | 347 | (if clear-parent (setf (eieio--class-parent newc) nil)) |
| @@ -390,8 +356,7 @@ It creates an autoload function for CNAME's constructor." | |||
| 390 | 356 | ||
| 391 | (defsubst eieio-class-un-autoload (cname) | 357 | (defsubst eieio-class-un-autoload (cname) |
| 392 | "If class CNAME is in an autoload state, load its file." | 358 | "If class CNAME is in an autoload state, load its file." |
| 393 | (when (eq (car-safe (symbol-function cname)) 'autoload) | 359 | (autoload-do-load (symbol-function cname))) ; cname |
| 394 | (load-library (car (cdr (symbol-function cname)))))) | ||
| 395 | 360 | ||
| 396 | (cl-deftype list-of (elem-type) | 361 | (cl-deftype list-of (elem-type) |
| 397 | `(and list | 362 | `(and list |
| @@ -399,11 +364,12 @@ It creates an autoload function for CNAME's constructor." | |||
| 399 | (cl-every (lambda (elem) (cl-typep elem ',elem-type)) | 364 | (cl-every (lambda (elem) (cl-typep elem ',elem-type)) |
| 400 | list))))) | 365 | list))))) |
| 401 | 366 | ||
| 402 | (defun eieio-defclass (cname superclasses slots options-and-doc) | 367 | (declare-function eieio--defmethod "eieio-generic" (method kind argclass code)) |
| 403 | ;; FIXME: Most of this should be moved to the `defclass' macro. | 368 | |
| 369 | (defun eieio-defclass-internal (cname superclasses slots options) | ||
| 404 | "Define CNAME as a new subclass of SUPERCLASSES. | 370 | "Define CNAME as a new subclass of SUPERCLASSES. |
| 405 | SLOTS are the slots residing in that class definition, and options or | 371 | SLOTS are the slots residing in that class definition, and OPTIONS |
| 406 | documentation OPTIONS-AND-DOC is the toplevel documentation for this class. | 372 | holds the class options. |
| 407 | See `defclass' for more information." | 373 | See `defclass' for more information." |
| 408 | ;; Run our eieio-hook each time, and clear it when we are done. | 374 | ;; Run our eieio-hook each time, and clear it when we are done. |
| 409 | ;; This way people can add hooks safely if they want to modify eieio | 375 | ;; This way people can add hooks safely if they want to modify eieio |
| @@ -411,18 +377,12 @@ See `defclass' for more information." | |||
| 411 | (run-hooks 'eieio-hook) | 377 | (run-hooks 'eieio-hook) |
| 412 | (setq eieio-hook nil) | 378 | (setq eieio-hook nil) |
| 413 | 379 | ||
| 414 | (eieio--check-type listp superclasses) | ||
| 415 | |||
| 416 | (let* ((pname superclasses) | 380 | (let* ((pname superclasses) |
| 417 | (newc (make-vector eieio--class-num-slots nil)) | 381 | (newc (eieio--class-make cname)) |
| 418 | (oldc (when (class-p cname) (class-v cname))) | 382 | (oldc (when (class-p cname) (eieio--class-v cname))) |
| 419 | (groups nil) ;; list of groups id'd from slots | 383 | (groups nil) ;; list of groups id'd from slots |
| 420 | (options nil) | ||
| 421 | (clearparent nil)) | 384 | (clearparent nil)) |
| 422 | 385 | ||
| 423 | (aset newc 0 'defclass) | ||
| 424 | (setf (eieio--class-symbol newc) cname) | ||
| 425 | |||
| 426 | ;; If this class already existed, and we are updating its structure, | 386 | ;; If this class already existed, and we are updating its structure, |
| 427 | ;; make sure we keep the old child list. This can cause bugs, but | 387 | ;; make sure we keep the old child list. This can cause bugs, but |
| 428 | ;; if no new slots are created, it also saves time, and prevents | 388 | ;; if no new slots are created, it also saves time, and prevents |
| @@ -430,123 +390,68 @@ See `defclass' for more information." | |||
| 430 | ;; byte compiling an EIEIO file. | 390 | ;; byte compiling an EIEIO file. |
| 431 | (if oldc | 391 | (if oldc |
| 432 | (setf (eieio--class-children newc) (eieio--class-children oldc)) | 392 | (setf (eieio--class-children newc) (eieio--class-children oldc)) |
| 433 | ;; If the old class did not exist, but did exist in the autoload map, then adopt those children. | 393 | ;; If the old class did not exist, but did exist in the autoload map, |
| 434 | ;; This is like the above, but deals with autoloads nicely. | 394 | ;; then adopt those children. This is like the above, but deals with |
| 435 | (let ((sym (intern-soft (symbol-name cname) eieio-defclass-autoload-map))) | 395 | ;; autoloads nicely. |
| 436 | (when sym | 396 | (let ((children (gethash cname eieio-defclass-autoload-map))) |
| 437 | (condition-case nil | 397 | (when children |
| 438 | (setf (eieio--class-children newc) (symbol-value sym)) | 398 | (setf (eieio--class-children newc) children) |
| 439 | (error nil)) | 399 | (remhash cname eieio-defclass-autoload-map)))) |
| 440 | (unintern (symbol-name cname) eieio-defclass-autoload-map) | ||
| 441 | )) | ||
| 442 | ) | ||
| 443 | |||
| 444 | (cond ((and (stringp (car options-and-doc)) | ||
| 445 | (/= 1 (% (length options-and-doc) 2))) | ||
| 446 | (error "Too many arguments to `defclass'")) | ||
| 447 | ((and (symbolp (car options-and-doc)) | ||
| 448 | (/= 0 (% (length options-and-doc) 2))) | ||
| 449 | (error "Too many arguments to `defclass'")) | ||
| 450 | ) | ||
| 451 | |||
| 452 | (setq options | ||
| 453 | (if (stringp (car options-and-doc)) | ||
| 454 | (cons :documentation options-and-doc) | ||
| 455 | options-and-doc)) | ||
| 456 | 400 | ||
| 457 | (if pname | 401 | (if pname |
| 458 | (progn | 402 | (progn |
| 459 | (while pname | 403 | (dolist (p pname) |
| 460 | (if (and (car pname) (symbolp (car pname))) | 404 | (if (and p (symbolp p)) |
| 461 | (if (not (class-p (car pname))) | 405 | (if (not (class-p p)) |
| 462 | ;; bad class | 406 | ;; bad class |
| 463 | (error "Given parent class %s is not a class" (car pname)) | 407 | (error "Given parent class %S is not a class" p) |
| 464 | ;; good parent class... | 408 | ;; good parent class... |
| 465 | ;; save new child in parent | 409 | ;; save new child in parent |
| 466 | (when (not (member cname (eieio--class-children (class-v (car pname))))) | 410 | (cl-pushnew cname (eieio--class-children (eieio--class-v p))) |
| 467 | (setf (eieio--class-children (class-v (car pname))) | ||
| 468 | (cons cname (eieio--class-children (class-v (car pname)))))) | ||
| 469 | ;; Get custom groups, and store them into our local copy. | 411 | ;; Get custom groups, and store them into our local copy. |
| 470 | (mapc (lambda (g) (cl-pushnew g groups :test #'equal)) | 412 | (mapc (lambda (g) (cl-pushnew g groups :test #'equal)) |
| 471 | (class-option (car pname) :custom-groups)) | 413 | (eieio--class-option (eieio--class-v p) :custom-groups)) |
| 472 | ;; save parent in child | 414 | ;; save parent in child |
| 473 | (setf (eieio--class-parent newc) (cons (car pname) (eieio--class-parent newc)))) | 415 | (push (eieio--class-v p) (eieio--class-parent newc))) |
| 474 | (error "Invalid parent class %s" pname)) | 416 | (error "Invalid parent class %S" p))) |
| 475 | (setq pname (cdr pname))) | ||
| 476 | ;; Reverse the list of our parents so that they are prioritized in | 417 | ;; Reverse the list of our parents so that they are prioritized in |
| 477 | ;; the same order as specified in the code. | 418 | ;; the same order as specified in the code. |
| 478 | (setf (eieio--class-parent newc) (nreverse (eieio--class-parent newc))) ) | 419 | (cl-callf nreverse (eieio--class-parent newc))) |
| 479 | ;; If there is nothing to loop over, then inherit from the | 420 | ;; If there is nothing to loop over, then inherit from the |
| 480 | ;; default superclass. | 421 | ;; default superclass. |
| 481 | (unless (eq cname 'eieio-default-superclass) | 422 | (unless (eq cname 'eieio-default-superclass) |
| 482 | ;; adopt the default parent here, but clear it later... | 423 | ;; adopt the default parent here, but clear it later... |
| 483 | (setq clearparent t) | 424 | (setq clearparent t) |
| 484 | ;; save new child in parent | 425 | ;; save new child in parent |
| 485 | (if (not (member cname (eieio--class-children (class-v 'eieio-default-superclass)))) | 426 | (cl-pushnew cname (eieio--class-children eieio-default-superclass)) |
| 486 | (setf (eieio--class-children (class-v 'eieio-default-superclass)) | 427 | ;; save parent in child |
| 487 | (cons cname (eieio--class-children (class-v 'eieio-default-superclass))))) | 428 | (setf (eieio--class-parent newc) (list eieio-default-superclass)))) |
| 488 | ;; save parent in child | ||
| 489 | (setf (eieio--class-parent newc) (list eieio-default-superclass)))) | ||
| 490 | |||
| 491 | ;; turn this into a usable self-pointing symbol | ||
| 492 | (set cname cname) | ||
| 493 | |||
| 494 | ;; These two tests must be created right away so we can have self- | ||
| 495 | ;; referencing classes. ei, a class whose slot can contain only | ||
| 496 | ;; pointers to itself. | ||
| 497 | |||
| 498 | ;; Create the test function | ||
| 499 | (let ((csym (intern (concat (symbol-name cname) "-p")))) | ||
| 500 | (fset csym | ||
| 501 | (list 'lambda (list 'obj) | ||
| 502 | (format "Test OBJ to see if it an object of type %s" cname) | ||
| 503 | (list 'and '(eieio-object-p obj) | ||
| 504 | (list 'same-class-p 'obj cname))))) | ||
| 505 | |||
| 506 | ;; Make sure the method invocation order is a valid value. | ||
| 507 | (let ((io (class-option-assoc options :method-invocation-order))) | ||
| 508 | (when (and io (not (member io '(:depth-first :breadth-first :c3)))) | ||
| 509 | (error "Method invocation order %s is not allowed" io) | ||
| 510 | )) | ||
| 511 | 429 | ||
| 512 | ;; Create a handy child test too | 430 | ;; turn this into a usable self-pointing symbol; FIXME: Why? |
| 513 | (let ((csym (intern (concat (symbol-name cname) "-child-p")))) | 431 | (when eieio-backward-compatibility |
| 514 | (fset csym | 432 | (set cname cname) |
| 515 | `(lambda (obj) | 433 | (make-obsolete-variable cname (format "use '%s instead" cname) "25.1")) |
| 516 | ,(format | ||
| 517 | "Test OBJ to see if it an object is a child of type %s" | ||
| 518 | cname) | ||
| 519 | (and (eieio-object-p obj) | ||
| 520 | (object-of-class-p obj ,cname)))) | ||
| 521 | 434 | ||
| 522 | ;; Create a handy list of the class test too | 435 | ;; Create a handy list of the class test too |
| 523 | (let ((csym (intern (concat (symbol-name cname) "-list-p")))) | 436 | (when eieio-backward-compatibility |
| 524 | (fset csym | 437 | (let ((csym (intern (concat (symbol-name cname) "-list-p")))) |
| 525 | `(lambda (obj) | 438 | (defalias csym |
| 526 | ,(format | 439 | `(lambda (obj) |
| 527 | "Test OBJ to see if it a list of objects which are a child of type %s" | 440 | ,(format |
| 528 | cname) | 441 | "Test OBJ to see if it a list of objects which are a child of type %s" |
| 529 | (when (listp obj) | 442 | cname) |
| 530 | (let ((ans t)) ;; nil is valid | 443 | (when (listp obj) |
| 531 | ;; Loop over all the elements of the input list, test | 444 | (let ((ans t)) ;; nil is valid |
| 532 | ;; each to make sure it is a child of the desired object class. | 445 | ;; Loop over all the elements of the input list, test |
| 533 | (while (and obj ans) | 446 | ;; each to make sure it is a child of the desired object class. |
| 534 | (setq ans (and (eieio-object-p (car obj)) | 447 | (while (and obj ans) |
| 535 | (object-of-class-p (car obj) ,cname))) | 448 | (setq ans (and (eieio-object-p (car obj)) |
| 536 | (setq obj (cdr obj))) | 449 | (object-of-class-p (car obj) ,cname))) |
| 537 | ans))))) | 450 | (setq obj (cdr obj))) |
| 538 | 451 | ans)))) | |
| 539 | ;; When using typep, (typep OBJ 'myclass) returns t for objects which | 452 | (make-obsolete csym (format "use (cl-typep ... '(list-of %s)) instead" |
| 540 | ;; are subclasses of myclass. For our predicates, however, it is | 453 | cname) |
| 541 | ;; important for EIEIO to be backwards compatible, where | 454 | "25.1"))) |
| 542 | ;; myobject-p, and myobject-child-p are different. | ||
| 543 | ;; "cl" uses this technique to specify symbols with specific typep | ||
| 544 | ;; test, so we can let typep have the CLOS documented behavior | ||
| 545 | ;; while keeping our above predicate clean. | ||
| 546 | |||
| 547 | ;; FIXME: It would be cleaner to use `cl-deftype' here. | ||
| 548 | (put cname 'cl-deftype-handler | ||
| 549 | (list 'lambda () `(list 'satisfies (quote ,csym))))) | ||
| 550 | 455 | ||
| 551 | ;; Before adding new slots, let's add all the methods and classes | 456 | ;; Before adding new slots, let's add all the methods and classes |
| 552 | ;; in from the parent class. | 457 | ;; in from the parent class. |
| @@ -556,78 +461,45 @@ See `defclass' for more information." | |||
| 556 | ;; do this first so that we can call defmethod for the accessor. | 461 | ;; do this first so that we can call defmethod for the accessor. |
| 557 | ;; The vector will be updated by the following while loop and will not | 462 | ;; The vector will be updated by the following while loop and will not |
| 558 | ;; need to be stored a second time. | 463 | ;; need to be stored a second time. |
| 559 | (put cname 'eieio-class-definition newc) | 464 | (setf (eieio--class-v cname) newc) |
| 560 | 465 | ||
| 561 | ;; Query each slot in the declaration list and mangle into the | 466 | ;; Query each slot in the declaration list and mangle into the |
| 562 | ;; class structure I have defined. | 467 | ;; class structure I have defined. |
| 563 | (while slots | 468 | (pcase-dolist (`(,name . ,slot) slots) |
| 564 | (let* ((slot1 (car slots)) | 469 | (let* ((init (or (plist-get slot :initform) |
| 565 | (name (car slot1)) | 470 | (if (member :initform slot) nil |
| 566 | (slot (cdr slot1)) | ||
| 567 | (acces (plist-get slot ':accessor)) | ||
| 568 | (init (or (plist-get slot ':initform) | ||
| 569 | (if (member ':initform slot) nil | ||
| 570 | eieio-unbound))) | 471 | eieio-unbound))) |
| 571 | (initarg (plist-get slot ':initarg)) | 472 | (initarg (plist-get slot :initarg)) |
| 572 | (docstr (plist-get slot ':documentation)) | 473 | (docstr (plist-get slot :documentation)) |
| 573 | (prot (plist-get slot ':protection)) | 474 | (prot (plist-get slot :protection)) |
| 574 | (reader (plist-get slot ':reader)) | 475 | (alloc (plist-get slot :allocation)) |
| 575 | (writer (plist-get slot ':writer)) | 476 | (type (plist-get slot :type)) |
| 576 | (alloc (plist-get slot ':allocation)) | 477 | (custom (plist-get slot :custom)) |
| 577 | (type (plist-get slot ':type)) | 478 | (label (plist-get slot :label)) |
| 578 | (custom (plist-get slot ':custom)) | 479 | (customg (plist-get slot :group)) |
| 579 | (label (plist-get slot ':label)) | 480 | (printer (plist-get slot :printer)) |
| 580 | (customg (plist-get slot ':group)) | 481 | |
| 581 | (printer (plist-get slot ':printer)) | 482 | (skip-nil (eieio--class-option-assoc options :allow-nil-initform)) |
| 582 | |||
| 583 | (skip-nil (class-option-assoc options :allow-nil-initform)) | ||
| 584 | ) | 483 | ) |
| 585 | 484 | ||
| 586 | (if eieio-error-unsupported-class-tags | ||
| 587 | (let ((tmp slot)) | ||
| 588 | (while tmp | ||
| 589 | (if (not (member (car tmp) '(:accessor | ||
| 590 | :initform | ||
| 591 | :initarg | ||
| 592 | :documentation | ||
| 593 | :protection | ||
| 594 | :reader | ||
| 595 | :writer | ||
| 596 | :allocation | ||
| 597 | :type | ||
| 598 | :custom | ||
| 599 | :label | ||
| 600 | :group | ||
| 601 | :printer | ||
| 602 | :allow-nil-initform | ||
| 603 | :custom-groups))) | ||
| 604 | (signal 'invalid-slot-type (list (car tmp)))) | ||
| 605 | (setq tmp (cdr (cdr tmp)))))) | ||
| 606 | |||
| 607 | ;; Clean up the meaning of protection. | 485 | ;; Clean up the meaning of protection. |
| 608 | (cond ((or (eq prot 'public) (eq prot :public)) (setq prot nil)) | 486 | (setq prot |
| 609 | ((or (eq prot 'protected) (eq prot :protected)) (setq prot 'protected)) | 487 | (pcase prot |
| 610 | ((or (eq prot 'private) (eq prot :private)) (setq prot 'private)) | 488 | ((or 'nil 'public ':public) nil) |
| 611 | ((eq prot nil) nil) | 489 | ((or 'protected ':protected) 'protected) |
| 612 | (t (signal 'invalid-slot-type (list ':protection prot)))) | 490 | ((or 'private ':private) 'private) |
| 613 | 491 | (_ (signal 'invalid-slot-type (list :protection prot))))) | |
| 614 | ;; Make sure the :allocation parameter has a valid value. | ||
| 615 | (if (not (or (not alloc) (eq alloc :class) (eq alloc :instance))) | ||
| 616 | (signal 'invalid-slot-type (list ':allocation alloc))) | ||
| 617 | 492 | ||
| 618 | ;; The default type specifier is supposed to be t, meaning anything. | 493 | ;; The default type specifier is supposed to be t, meaning anything. |
| 619 | (if (not type) (setq type t)) | 494 | (if (not type) (setq type t)) |
| 620 | 495 | ||
| 621 | ;; Label is nil, or a string | ||
| 622 | (if (not (or (null label) (stringp label))) | ||
| 623 | (signal 'invalid-slot-type (list ':label label))) | ||
| 624 | |||
| 625 | ;; Is there an initarg, but allocation of class? | ||
| 626 | (if (and initarg (eq alloc :class)) | ||
| 627 | (message "Class allocated slots do not need :initarg")) | ||
| 628 | |||
| 629 | ;; intern the symbol so we can use it blankly | 496 | ;; intern the symbol so we can use it blankly |
| 630 | (if initarg (set initarg initarg)) | 497 | (if eieio-backward-compatibility |
| 498 | (and initarg (not (keywordp initarg)) | ||
| 499 | (progn | ||
| 500 | (set initarg initarg) | ||
| 501 | (make-obsolete-variable | ||
| 502 | initarg (format "use '%s instead" initarg) "25.1")))) | ||
| 631 | 503 | ||
| 632 | ;; The customgroup should be a list of symbols | 504 | ;; The customgroup should be a list of symbols |
| 633 | (cond ((null customg) | 505 | (cond ((null customg) |
| @@ -637,131 +509,60 @@ See `defclass' for more information." | |||
| 637 | ;; The customgroup better be a symbol, or list of symbols. | 509 | ;; The customgroup better be a symbol, or list of symbols. |
| 638 | (mapc (lambda (cg) | 510 | (mapc (lambda (cg) |
| 639 | (if (not (symbolp cg)) | 511 | (if (not (symbolp cg)) |
| 640 | (signal 'invalid-slot-type (list ':group cg)))) | 512 | (signal 'invalid-slot-type (list :group cg)))) |
| 641 | customg) | 513 | customg) |
| 642 | 514 | ||
| 643 | ;; First up, add this slot into our new class. | 515 | ;; First up, add this slot into our new class. |
| 644 | (eieio-add-new-slot newc name init docstr type custom label customg printer | 516 | (eieio--add-new-slot newc name init docstr type custom label customg printer |
| 645 | prot initarg alloc 'defaultoverride skip-nil) | 517 | prot initarg alloc 'defaultoverride skip-nil) |
| 646 | 518 | ||
| 647 | ;; We need to id the group, and store them in a group list attribute. | 519 | ;; We need to id the group, and store them in a group list attribute. |
| 648 | (mapc (lambda (cg) (cl-pushnew cg groups :test 'equal)) customg) | 520 | (dolist (cg customg) |
| 649 | 521 | (cl-pushnew cg groups :test 'equal)) | |
| 650 | ;; Anyone can have an accessor function. This creates a function | 522 | )) |
| 651 | ;; of the specified name, and also performs a `defsetf' if applicable | ||
| 652 | ;; so that users can `setf' the space returned by this function. | ||
| 653 | (if acces | ||
| 654 | (progn | ||
| 655 | (eieio--defmethod | ||
| 656 | acces (if (eq alloc :class) :static :primary) cname | ||
| 657 | `(lambda (this) | ||
| 658 | ,(format | ||
| 659 | "Retrieves the slot `%s' from an object of class `%s'" | ||
| 660 | name cname) | ||
| 661 | (if (slot-boundp this ',name) | ||
| 662 | (eieio-oref this ',name) | ||
| 663 | ;; Else - Some error? nil? | ||
| 664 | nil))) | ||
| 665 | |||
| 666 | ;; FIXME: We should move more of eieio-defclass into the | ||
| 667 | ;; defclass macro so we don't have to use `eval' and require | ||
| 668 | ;; `gv' at run-time. | ||
| 669 | (eval `(gv-define-setter ,acces (eieio--store eieio--object) | ||
| 670 | (list 'eieio-oset eieio--object '',name | ||
| 671 | eieio--store))))) | ||
| 672 | |||
| 673 | ;; If a writer is defined, then create a generic method of that | ||
| 674 | ;; name whose purpose is to set the value of the slot. | ||
| 675 | (if writer | ||
| 676 | (eieio--defmethod | ||
| 677 | writer nil cname | ||
| 678 | `(lambda (this value) | ||
| 679 | ,(format "Set the slot `%s' of an object of class `%s'" | ||
| 680 | name cname) | ||
| 681 | (setf (slot-value this ',name) value)))) | ||
| 682 | ;; If a reader is defined, then create a generic method | ||
| 683 | ;; of that name whose purpose is to access this slot value. | ||
| 684 | (if reader | ||
| 685 | (eieio--defmethod | ||
| 686 | reader nil cname | ||
| 687 | `(lambda (this) | ||
| 688 | ,(format "Access the slot `%s' from object of class `%s'" | ||
| 689 | name cname) | ||
| 690 | (slot-value this ',name)))) | ||
| 691 | ) | ||
| 692 | (setq slots (cdr slots))) | ||
| 693 | 523 | ||
| 694 | ;; Now that everything has been loaded up, all our lists are backwards! | 524 | ;; Now that everything has been loaded up, all our lists are backwards! |
| 695 | ;; Fix that up now. | 525 | ;; Fix that up now. |
| 696 | (setf (eieio--class-public-a newc) (nreverse (eieio--class-public-a newc))) | 526 | (cl-callf nreverse (eieio--class-public-a newc)) |
| 697 | (setf (eieio--class-public-d newc) (nreverse (eieio--class-public-d newc))) | 527 | (cl-callf nreverse (eieio--class-public-d newc)) |
| 698 | (setf (eieio--class-public-doc newc) (nreverse (eieio--class-public-doc newc))) | 528 | (cl-callf nreverse (eieio--class-public-doc newc)) |
| 699 | (setf (eieio--class-public-type newc) | 529 | (cl-callf (lambda (types) (apply #'vector (nreverse types))) |
| 700 | (apply #'vector (nreverse (eieio--class-public-type newc)))) | 530 | (eieio--class-public-type newc)) |
| 701 | (setf (eieio--class-public-custom newc) (nreverse (eieio--class-public-custom newc))) | 531 | (cl-callf nreverse (eieio--class-public-custom newc)) |
| 702 | (setf (eieio--class-public-custom-label newc) (nreverse (eieio--class-public-custom-label newc))) | 532 | (cl-callf nreverse (eieio--class-public-custom-label newc)) |
| 703 | (setf (eieio--class-public-custom-group newc) (nreverse (eieio--class-public-custom-group newc))) | 533 | (cl-callf nreverse (eieio--class-public-custom-group newc)) |
| 704 | (setf (eieio--class-public-printer newc) (nreverse (eieio--class-public-printer newc))) | 534 | (cl-callf nreverse (eieio--class-public-printer newc)) |
| 705 | (setf (eieio--class-protection newc) (nreverse (eieio--class-protection newc))) | 535 | (cl-callf nreverse (eieio--class-protection newc)) |
| 706 | (setf (eieio--class-initarg-tuples newc) (nreverse (eieio--class-initarg-tuples newc))) | 536 | (cl-callf nreverse (eieio--class-initarg-tuples newc)) |
| 707 | 537 | ||
| 708 | ;; The storage for class-class-allocation-type needs to be turned into | 538 | ;; The storage for class-class-allocation-type needs to be turned into |
| 709 | ;; a vector now. | 539 | ;; a vector now. |
| 710 | (setf (eieio--class-class-allocation-type newc) | 540 | (cl-callf (lambda (cat) (apply #'vector cat)) |
| 711 | (apply #'vector (eieio--class-class-allocation-type newc))) | 541 | (eieio--class-class-allocation-type newc)) |
| 712 | 542 | ||
| 713 | ;; Also, take class allocated values, and vectorize them for speed. | 543 | ;; Also, take class allocated values, and vectorize them for speed. |
| 714 | (setf (eieio--class-class-allocation-values newc) | 544 | (cl-callf (lambda (cavs) (apply #'vector cavs)) |
| 715 | (apply #'vector (eieio--class-class-allocation-values newc))) | 545 | (eieio--class-class-allocation-values newc)) |
| 716 | 546 | ||
| 717 | ;; Attach slot symbols into an obarray, and store the index of | 547 | ;; Attach slot symbols into a hashtable, and store the index of |
| 718 | ;; this slot as the variable slot in this new symbol. We need to | 548 | ;; this slot as the value this table. |
| 719 | ;; know about primes, because obarrays are best set in vectors of | ||
| 720 | ;; prime number length, and we also need to make our vector small | ||
| 721 | ;; to save space, and also optimal for the number of items we have. | ||
| 722 | (let* ((cnt 0) | 549 | (let* ((cnt 0) |
| 723 | (pubsyms (eieio--class-public-a newc)) | 550 | (pubsyms (eieio--class-public-a newc)) |
| 724 | (prots (eieio--class-protection newc)) | 551 | (prots (eieio--class-protection newc)) |
| 725 | (l (length pubsyms)) | 552 | (oa (make-hash-table :test #'eq))) |
| 726 | (vl (let ((primes '( 3 5 7 11 13 17 19 23 29 31 37 41 43 47 | ||
| 727 | 53 59 61 67 71 73 79 83 89 97 101 ))) | ||
| 728 | (while (and primes (< (car primes) l)) | ||
| 729 | (setq primes (cdr primes))) | ||
| 730 | (car primes))) | ||
| 731 | (oa (make-vector vl 0)) | ||
| 732 | (newsym)) | ||
| 733 | (while pubsyms | 553 | (while pubsyms |
| 734 | (setq newsym (intern (symbol-name (car pubsyms)) oa)) | 554 | (let ((newsym (list cnt))) |
| 735 | (set newsym cnt) | 555 | (setf (gethash (car pubsyms) oa) newsym) |
| 736 | (setq cnt (1+ cnt)) | 556 | (setq cnt (1+ cnt)) |
| 737 | (if (car prots) (put newsym 'protection (car prots))) | 557 | (if (car prots) (setcdr newsym (car prots)))) |
| 738 | (setq pubsyms (cdr pubsyms) | 558 | (setq pubsyms (cdr pubsyms) |
| 739 | prots (cdr prots))) | 559 | prots (cdr prots))) |
| 740 | (setf (eieio--class-symbol-obarray newc) oa) | 560 | (setf (eieio--class-symbol-hashtable newc) oa)) |
| 741 | ) | ||
| 742 | |||
| 743 | ;; Create the constructor function | ||
| 744 | (if (class-option-assoc options :abstract) | ||
| 745 | ;; Abstract classes cannot be instantiated. Say so. | ||
| 746 | (let ((abs (class-option-assoc options :abstract))) | ||
| 747 | (if (not (stringp abs)) | ||
| 748 | (setq abs (format "Class %s is abstract" cname))) | ||
| 749 | (fset cname | ||
| 750 | `(lambda (&rest stuff) | ||
| 751 | ,(format "You cannot create a new object of type %s" cname) | ||
| 752 | (error ,abs)))) | ||
| 753 | |||
| 754 | ;; Non-abstract classes need a constructor. | ||
| 755 | (fset cname | ||
| 756 | `(lambda (newname &rest slots) | ||
| 757 | ,(format "Create a new object with name NAME of class type %s" cname) | ||
| 758 | (apply #'constructor ,cname newname slots))) | ||
| 759 | ) | ||
| 760 | 561 | ||
| 761 | ;; Set up a specialized doc string. | 562 | ;; Set up a specialized doc string. |
| 762 | ;; Use stored value since it is calculated in a non-trivial way | 563 | ;; Use stored value since it is calculated in a non-trivial way |
| 763 | (put cname 'variable-documentation | 564 | (put cname 'variable-documentation |
| 764 | (class-option-assoc options :documentation)) | 565 | (eieio--class-option-assoc options :documentation)) |
| 765 | 566 | ||
| 766 | ;; Save the file location where this class is defined. | 567 | ;; Save the file location where this class is defined. |
| 767 | (let ((fname (if load-in-progress | 568 | (let ((fname (if load-in-progress |
| @@ -773,7 +574,7 @@ See `defclass' for more information." | |||
| 773 | (put cname 'class-location fname))) | 574 | (put cname 'class-location fname))) |
| 774 | 575 | ||
| 775 | ;; We have a list of custom groups. Store them into the options. | 576 | ;; We have a list of custom groups. Store them into the options. |
| 776 | (let ((g (class-option-assoc options :custom-groups))) | 577 | (let ((g (eieio--class-option-assoc options :custom-groups))) |
| 777 | (mapc (lambda (cg) (cl-pushnew cg g :test 'equal)) groups) | 578 | (mapc (lambda (cg) (cl-pushnew cg g :test 'equal)) groups) |
| 778 | (if (memq :custom-groups options) | 579 | (if (memq :custom-groups options) |
| 779 | (setcar (cdr (memq :custom-groups options)) g) | 580 | (setcar (cdr (memq :custom-groups options)) g) |
| @@ -787,11 +588,17 @@ See `defclass' for more information." | |||
| 787 | (if clearparent (setf (eieio--class-parent newc) nil)) | 588 | (if clearparent (setf (eieio--class-parent newc) nil)) |
| 788 | 589 | ||
| 789 | ;; Create the cached default object. | 590 | ;; Create the cached default object. |
| 790 | (let ((cache (make-vector (+ (length (eieio--class-public-a newc)) 3) | 591 | (let ((cache (make-vector (+ (length (eieio--class-public-a newc)) |
| 791 | nil))) | 592 | (eval-when-compile eieio--object-num-slots)) |
| 792 | (aset cache 0 'object) | 593 | nil)) |
| 793 | (setf (eieio--object-class cache) cname) | 594 | ;; We don't strictly speaking need to use a symbol, but the old |
| 794 | (setf (eieio--object-name cache) 'default-cache-object) | 595 | ;; code used the class's name rather than the class's object, so |
| 596 | ;; we follow this preference for using a symbol, which is probably | ||
| 597 | ;; convenient to keep the printed representation of such Elisp | ||
| 598 | ;; objects readable. | ||
| 599 | (tag (intern (format "eieio-class-tag--%s" cname)))) | ||
| 600 | (set tag newc) | ||
| 601 | (setf (eieio--object-class-tag cache) tag) | ||
| 795 | (let ((eieio-skip-typecheck t)) | 602 | (let ((eieio-skip-typecheck t)) |
| 796 | ;; All type-checking has been done to our satisfaction | 603 | ;; All type-checking has been done to our satisfaction |
| 797 | ;; before this call. Don't waste our time in this call.. | 604 | ;; before this call. Don't waste our time in this call.. |
| @@ -807,16 +614,16 @@ See `defclass' for more information." | |||
| 807 | "Whether the default value VAL should be evaluated for use." | 614 | "Whether the default value VAL should be evaluated for use." |
| 808 | (and (consp val) (symbolp (car val)) (fboundp (car val)))) | 615 | (and (consp val) (symbolp (car val)) (fboundp (car val)))) |
| 809 | 616 | ||
| 810 | (defun eieio-perform-slot-validation-for-default (slot spec value skipnil) | 617 | (defun eieio--perform-slot-validation-for-default (slot spec value skipnil) |
| 811 | "For SLOT, signal if SPEC does not match VALUE. | 618 | "For SLOT, signal if SPEC does not match VALUE. |
| 812 | If SKIPNIL is non-nil, then if VALUE is nil return t instead." | 619 | If SKIPNIL is non-nil, then if VALUE is nil return t instead." |
| 813 | (if (and (not (eieio-eval-default-p value)) | 620 | (if (not (or (eieio-eval-default-p value) ;FIXME: Why? |
| 814 | (not eieio-skip-typecheck) | 621 | eieio-skip-typecheck |
| 815 | (not (and skipnil (null value))) | 622 | (and skipnil (null value)) |
| 816 | (not (eieio-perform-slot-validation spec value))) | 623 | (eieio--perform-slot-validation spec value))) |
| 817 | (signal 'invalid-slot-type (list slot spec value)))) | 624 | (signal 'invalid-slot-type (list slot spec value)))) |
| 818 | 625 | ||
| 819 | (defun eieio-add-new-slot (newc a d doc type cust label custg print prot init alloc | 626 | (defun eieio--add-new-slot (newc a d doc type cust label custg print prot init alloc |
| 820 | &optional defaultoverride skipnil) | 627 | &optional defaultoverride skipnil) |
| 821 | "Add into NEWC attribute A. | 628 | "Add into NEWC attribute A. |
| 822 | If A already exists in NEWC, then do nothing. If it doesn't exist, | 629 | If A already exists in NEWC, then do nothing. If it doesn't exist, |
| @@ -837,9 +644,9 @@ if default value is nil." | |||
| 837 | 644 | ||
| 838 | ;; To prevent override information w/out specification of storage, | 645 | ;; To prevent override information w/out specification of storage, |
| 839 | ;; we need to do this little hack. | 646 | ;; we need to do this little hack. |
| 840 | (if (member a (eieio--class-class-allocation-a newc)) (setq alloc ':class)) | 647 | (if (member a (eieio--class-class-allocation-a newc)) (setq alloc :class)) |
| 841 | 648 | ||
| 842 | (if (or (not alloc) (and (symbolp alloc) (eq alloc ':instance))) | 649 | (if (or (not alloc) (and (symbolp alloc) (eq alloc :instance))) |
| 843 | ;; In this case, we modify the INSTANCE version of a given slot. | 650 | ;; In this case, we modify the INSTANCE version of a given slot. |
| 844 | 651 | ||
| 845 | (progn | 652 | (progn |
| @@ -847,16 +654,16 @@ if default value is nil." | |||
| 847 | ;; Only add this element if it is so-far unique | 654 | ;; Only add this element if it is so-far unique |
| 848 | (if (not (member a (eieio--class-public-a newc))) | 655 | (if (not (member a (eieio--class-public-a newc))) |
| 849 | (progn | 656 | (progn |
| 850 | (eieio-perform-slot-validation-for-default a type d skipnil) | 657 | (eieio--perform-slot-validation-for-default a type d skipnil) |
| 851 | (setf (eieio--class-public-a newc) (cons a (eieio--class-public-a newc))) | 658 | (push a (eieio--class-public-a newc)) |
| 852 | (setf (eieio--class-public-d newc) (cons d (eieio--class-public-d newc))) | 659 | (push d (eieio--class-public-d newc)) |
| 853 | (setf (eieio--class-public-doc newc) (cons doc (eieio--class-public-doc newc))) | 660 | (push doc (eieio--class-public-doc newc)) |
| 854 | (setf (eieio--class-public-type newc) (cons type (eieio--class-public-type newc))) | 661 | (push type (eieio--class-public-type newc)) |
| 855 | (setf (eieio--class-public-custom newc) (cons cust (eieio--class-public-custom newc))) | 662 | (push cust (eieio--class-public-custom newc)) |
| 856 | (setf (eieio--class-public-custom-label newc) (cons label (eieio--class-public-custom-label newc))) | 663 | (push label (eieio--class-public-custom-label newc)) |
| 857 | (setf (eieio--class-public-custom-group newc) (cons custg (eieio--class-public-custom-group newc))) | 664 | (push custg (eieio--class-public-custom-group newc)) |
| 858 | (setf (eieio--class-public-printer newc) (cons print (eieio--class-public-printer newc))) | 665 | (push print (eieio--class-public-printer newc)) |
| 859 | (setf (eieio--class-protection newc) (cons prot (eieio--class-protection newc))) | 666 | (push prot (eieio--class-protection newc)) |
| 860 | (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc))) | 667 | (setf (eieio--class-initarg-tuples newc) (cons (cons init a) (eieio--class-initarg-tuples newc))) |
| 861 | ) | 668 | ) |
| 862 | ;; When defaultoverride is true, we are usually adding new local | 669 | ;; When defaultoverride is true, we are usually adding new local |
| @@ -882,7 +689,7 @@ if default value is nil." | |||
| 882 | type tp a))) | 689 | type tp a))) |
| 883 | ;; If we have a repeat, only update the initarg... | 690 | ;; If we have a repeat, only update the initarg... |
| 884 | (unless (eq d eieio-unbound) | 691 | (unless (eq d eieio-unbound) |
| 885 | (eieio-perform-slot-validation-for-default a tp d skipnil) | 692 | (eieio--perform-slot-validation-for-default a tp d skipnil) |
| 886 | (setcar dp d)) | 693 | (setcar dp d)) |
| 887 | ;; If we have a new initarg, check for it. | 694 | ;; If we have a new initarg, check for it. |
| 888 | (when init | 695 | (when init |
| @@ -959,19 +766,19 @@ if default value is nil." | |||
| 959 | (let ((value (eieio-default-eval-maybe d))) | 766 | (let ((value (eieio-default-eval-maybe d))) |
| 960 | (if (not (member a (eieio--class-class-allocation-a newc))) | 767 | (if (not (member a (eieio--class-class-allocation-a newc))) |
| 961 | (progn | 768 | (progn |
| 962 | (eieio-perform-slot-validation-for-default a type value skipnil) | 769 | (eieio--perform-slot-validation-for-default a type value skipnil) |
| 963 | ;; Here we have found a :class version of a slot. This | 770 | ;; Here we have found a :class version of a slot. This |
| 964 | ;; requires a very different approach. | 771 | ;; requires a very different approach. |
| 965 | (setf (eieio--class-class-allocation-a newc) (cons a (eieio--class-class-allocation-a newc))) | 772 | (push a (eieio--class-class-allocation-a newc)) |
| 966 | (setf (eieio--class-class-allocation-doc newc) (cons doc (eieio--class-class-allocation-doc newc))) | 773 | (push doc (eieio--class-class-allocation-doc newc)) |
| 967 | (setf (eieio--class-class-allocation-type newc) (cons type (eieio--class-class-allocation-type newc))) | 774 | (push type (eieio--class-class-allocation-type newc)) |
| 968 | (setf (eieio--class-class-allocation-custom newc) (cons cust (eieio--class-class-allocation-custom newc))) | 775 | (push cust (eieio--class-class-allocation-custom newc)) |
| 969 | (setf (eieio--class-class-allocation-custom-label newc) (cons label (eieio--class-class-allocation-custom-label newc))) | 776 | (push label (eieio--class-class-allocation-custom-label newc)) |
| 970 | (setf (eieio--class-class-allocation-custom-group newc) (cons custg (eieio--class-class-allocation-custom-group newc))) | 777 | (push custg (eieio--class-class-allocation-custom-group newc)) |
| 971 | (setf (eieio--class-class-allocation-protection newc) (cons prot (eieio--class-class-allocation-protection newc))) | 778 | (push prot (eieio--class-class-allocation-protection newc)) |
| 972 | ;; Default value is stored in the 'values section, since new objects | 779 | ;; Default value is stored in the 'values section, since new objects |
| 973 | ;; can't initialize from this element. | 780 | ;; can't initialize from this element. |
| 974 | (setf (eieio--class-class-allocation-values newc) (cons value (eieio--class-class-allocation-values newc)))) | 781 | (push value (eieio--class-class-allocation-values newc))) |
| 975 | (when defaultoverride | 782 | (when defaultoverride |
| 976 | ;; There is a match, and we must override the old value. | 783 | ;; There is a match, and we must override the old value. |
| 977 | (let* ((ca (eieio--class-class-allocation-a newc)) | 784 | (let* ((ca (eieio--class-class-allocation-a newc)) |
| @@ -996,7 +803,7 @@ if default value is nil." | |||
| 996 | ;; is to change the default, so allow unbound in. | 803 | ;; is to change the default, so allow unbound in. |
| 997 | 804 | ||
| 998 | ;; If we have a repeat, only update the value... | 805 | ;; If we have a repeat, only update the value... |
| 999 | (eieio-perform-slot-validation-for-default a tp value skipnil) | 806 | (eieio--perform-slot-validation-for-default a tp value skipnil) |
| 1000 | (setcar dp value)) | 807 | (setcar dp value)) |
| 1001 | 808 | ||
| 1002 | ;; PLN Tue Jun 26 11:57:06 2007 : The protection is | 809 | ;; PLN Tue Jun 26 11:57:06 2007 : The protection is |
| @@ -1045,246 +852,81 @@ if default value is nil." | |||
| 1045 | "Copy into NEWC the slots of PARENTS. | 852 | "Copy into NEWC the slots of PARENTS. |
| 1046 | Follow the rules of not overwriting early parents when applying to | 853 | Follow the rules of not overwriting early parents when applying to |
| 1047 | the new child class." | 854 | the new child class." |
| 1048 | (let ((ps (eieio--class-parent newc)) | 855 | (let ((sn (eieio--class-option-assoc (eieio--class-options newc) |
| 1049 | (sn (class-option-assoc (eieio--class-options newc) | 856 | :allow-nil-initform))) |
| 1050 | ':allow-nil-initform))) | 857 | (dolist (pcv (eieio--class-parent newc)) |
| 1051 | (while ps | ||
| 1052 | ;; First, duplicate all the slots of the parent. | 858 | ;; First, duplicate all the slots of the parent. |
| 1053 | (let ((pcv (class-v (car ps)))) | 859 | (let ((pa (eieio--class-public-a pcv)) |
| 1054 | (let ((pa (eieio--class-public-a pcv)) | 860 | (pd (eieio--class-public-d pcv)) |
| 1055 | (pd (eieio--class-public-d pcv)) | 861 | (pdoc (eieio--class-public-doc pcv)) |
| 1056 | (pdoc (eieio--class-public-doc pcv)) | 862 | (ptype (eieio--class-public-type pcv)) |
| 1057 | (ptype (eieio--class-public-type pcv)) | 863 | (pcust (eieio--class-public-custom pcv)) |
| 1058 | (pcust (eieio--class-public-custom pcv)) | 864 | (plabel (eieio--class-public-custom-label pcv)) |
| 1059 | (plabel (eieio--class-public-custom-label pcv)) | 865 | (pcustg (eieio--class-public-custom-group pcv)) |
| 1060 | (pcustg (eieio--class-public-custom-group pcv)) | 866 | (printer (eieio--class-public-printer pcv)) |
| 1061 | (printer (eieio--class-public-printer pcv)) | 867 | (pprot (eieio--class-protection pcv)) |
| 1062 | (pprot (eieio--class-protection pcv)) | 868 | (pinit (eieio--class-initarg-tuples pcv)) |
| 1063 | (pinit (eieio--class-initarg-tuples pcv)) | 869 | (i 0)) |
| 1064 | (i 0)) | 870 | (while pa |
| 1065 | (while pa | 871 | (eieio--add-new-slot newc |
| 1066 | (eieio-add-new-slot newc | 872 | (car pa) (car pd) (car pdoc) (aref ptype i) |
| 1067 | (car pa) (car pd) (car pdoc) (aref ptype i) | 873 | (car pcust) (car plabel) (car pcustg) |
| 1068 | (car pcust) (car plabel) (car pcustg) | 874 | (car printer) |
| 1069 | (car printer) | 875 | (car pprot) (car-safe (car pinit)) nil nil sn) |
| 1070 | (car pprot) (car-safe (car pinit)) nil nil sn) | 876 | ;; Increment each value. |
| 1071 | ;; Increment each value. | 877 | (setq pa (cdr pa) |
| 1072 | (setq pa (cdr pa) | 878 | pd (cdr pd) |
| 1073 | pd (cdr pd) | 879 | pdoc (cdr pdoc) |
| 1074 | pdoc (cdr pdoc) | 880 | i (1+ i) |
| 1075 | i (1+ i) | 881 | pcust (cdr pcust) |
| 1076 | pcust (cdr pcust) | 882 | plabel (cdr plabel) |
| 1077 | plabel (cdr plabel) | 883 | pcustg (cdr pcustg) |
| 1078 | pcustg (cdr pcustg) | 884 | printer (cdr printer) |
| 1079 | printer (cdr printer) | 885 | pprot (cdr pprot) |
| 1080 | pprot (cdr pprot) | 886 | pinit (cdr pinit)) |
| 1081 | pinit (cdr pinit)) | 887 | )) ;; while/let |
| 1082 | )) ;; while/let | 888 | ;; Now duplicate all the class alloc slots. |
| 1083 | ;; Now duplicate all the class alloc slots. | 889 | (let ((pa (eieio--class-class-allocation-a pcv)) |
| 1084 | (let ((pa (eieio--class-class-allocation-a pcv)) | 890 | (pdoc (eieio--class-class-allocation-doc pcv)) |
| 1085 | (pdoc (eieio--class-class-allocation-doc pcv)) | 891 | (ptype (eieio--class-class-allocation-type pcv)) |
| 1086 | (ptype (eieio--class-class-allocation-type pcv)) | 892 | (pcust (eieio--class-class-allocation-custom pcv)) |
| 1087 | (pcust (eieio--class-class-allocation-custom pcv)) | 893 | (plabel (eieio--class-class-allocation-custom-label pcv)) |
| 1088 | (plabel (eieio--class-class-allocation-custom-label pcv)) | 894 | (pcustg (eieio--class-class-allocation-custom-group pcv)) |
| 1089 | (pcustg (eieio--class-class-allocation-custom-group pcv)) | 895 | (printer (eieio--class-class-allocation-printer pcv)) |
| 1090 | (printer (eieio--class-class-allocation-printer pcv)) | 896 | (pprot (eieio--class-class-allocation-protection pcv)) |
| 1091 | (pprot (eieio--class-class-allocation-protection pcv)) | 897 | (pval (eieio--class-class-allocation-values pcv)) |
| 1092 | (pval (eieio--class-class-allocation-values pcv)) | 898 | (i 0)) |
| 1093 | (i 0)) | 899 | (while pa |
| 1094 | (while pa | 900 | (eieio--add-new-slot newc |
| 1095 | (eieio-add-new-slot newc | 901 | (car pa) (aref pval i) (car pdoc) (aref ptype i) |
| 1096 | (car pa) (aref pval i) (car pdoc) (aref ptype i) | 902 | (car pcust) (car plabel) (car pcustg) |
| 1097 | (car pcust) (car plabel) (car pcustg) | 903 | (car printer) |
| 1098 | (car printer) | 904 | (car pprot) nil :class sn) |
| 1099 | (car pprot) nil ':class sn) | 905 | ;; Increment each value. |
| 1100 | ;; Increment each value. | 906 | (setq pa (cdr pa) |
| 1101 | (setq pa (cdr pa) | 907 | pdoc (cdr pdoc) |
| 1102 | pdoc (cdr pdoc) | 908 | pcust (cdr pcust) |
| 1103 | pcust (cdr pcust) | 909 | plabel (cdr plabel) |
| 1104 | plabel (cdr plabel) | 910 | pcustg (cdr pcustg) |
| 1105 | pcustg (cdr pcustg) | 911 | printer (cdr printer) |
| 1106 | printer (cdr printer) | 912 | pprot (cdr pprot) |
| 1107 | pprot (cdr pprot) | 913 | i (1+ i)) |
| 1108 | i (1+ i)) | 914 | ))))) |
| 1109 | ))) ;; while/let | ||
| 1110 | ;; Loop over each parent class | ||
| 1111 | (setq ps (cdr ps))) | ||
| 1112 | )) | ||
| 1113 | 915 | ||
| 1114 | 916 | ||
| 1115 | ;;; CLOS methods and generics | ||
| 1116 | ;; | ||
| 1117 | |||
| 1118 | (defun eieio--defgeneric-init-form (method doc-string) | ||
| 1119 | "Form to use for the initial definition of a generic." | ||
| 1120 | (cond | ||
| 1121 | ((or (not (fboundp method)) | ||
| 1122 | (eq 'autoload (car-safe (symbol-function method)))) | ||
| 1123 | ;; Make sure the method tables are installed. | ||
| 1124 | (eieiomt-install method) | ||
| 1125 | ;; Construct the actual body of this function. | ||
| 1126 | (eieio-defgeneric-form method doc-string)) | ||
| 1127 | ((generic-p method) (symbol-function method)) ;Leave it as-is. | ||
| 1128 | (t (error "You cannot create a generic/method over an existing symbol: %s" | ||
| 1129 | method)))) | ||
| 1130 | |||
| 1131 | (defun eieio-defgeneric-form (method doc-string) | ||
| 1132 | "The lambda form that would be used as the function defined on METHOD. | ||
| 1133 | All methods should call the same EIEIO function for dispatch. | ||
| 1134 | DOC-STRING is the documentation attached to METHOD." | ||
| 1135 | `(lambda (&rest local-args) | ||
| 1136 | ,doc-string | ||
| 1137 | (eieio-generic-call (quote ,method) local-args))) | ||
| 1138 | |||
| 1139 | (defsubst eieio-defgeneric-reset-generic-form (method) | ||
| 1140 | "Setup METHOD to call the generic form." | ||
| 1141 | (let ((doc-string (documentation method))) | ||
| 1142 | (fset method (eieio-defgeneric-form method doc-string)))) | ||
| 1143 | |||
| 1144 | (defun eieio-defgeneric-form-primary-only (method doc-string) | ||
| 1145 | "The lambda form that would be used as the function defined on METHOD. | ||
| 1146 | All methods should call the same EIEIO function for dispatch. | ||
| 1147 | DOC-STRING is the documentation attached to METHOD." | ||
| 1148 | `(lambda (&rest local-args) | ||
| 1149 | ,doc-string | ||
| 1150 | (eieio-generic-call-primary-only (quote ,method) local-args))) | ||
| 1151 | |||
| 1152 | (defsubst eieio-defgeneric-reset-generic-form-primary-only (method) | ||
| 1153 | "Setup METHOD to call the generic form." | ||
| 1154 | (let ((doc-string (documentation method))) | ||
| 1155 | (fset method (eieio-defgeneric-form-primary-only method doc-string)))) | ||
| 1156 | |||
| 1157 | (declare-function no-applicable-method "eieio" (object method &rest args)) | ||
| 1158 | |||
| 1159 | (defun eieio-defgeneric-form-primary-only-one (method doc-string | ||
| 1160 | class | ||
| 1161 | impl | ||
| 1162 | ) | ||
| 1163 | "The lambda form that would be used as the function defined on METHOD. | ||
| 1164 | All methods should call the same EIEIO function for dispatch. | ||
| 1165 | DOC-STRING is the documentation attached to METHOD. | ||
| 1166 | CLASS is the class symbol needed for private method access. | ||
| 1167 | IMPL is the symbol holding the method implementation." | ||
| 1168 | ;; NOTE: I tried out byte compiling this little fcn. Turns out it | ||
| 1169 | ;; is faster to execute this for not byte-compiled. ie, install this, | ||
| 1170 | ;; then measure calls going through here. I wonder why. | ||
| 1171 | (require 'bytecomp) | ||
| 1172 | (let ((byte-compile-warnings nil)) | ||
| 1173 | (byte-compile | ||
| 1174 | `(lambda (&rest local-args) | ||
| 1175 | ,doc-string | ||
| 1176 | ;; This is a cool cheat. Usually we need to look up in the | ||
| 1177 | ;; method table to find out if there is a method or not. We can | ||
| 1178 | ;; instead make that determination at load time when there is | ||
| 1179 | ;; only one method. If the first arg is not a child of the class | ||
| 1180 | ;; of that one implementation, then clearly, there is no method def. | ||
| 1181 | (if (not (eieio-object-p (car local-args))) | ||
| 1182 | ;; Not an object. Just signal. | ||
| 1183 | (signal 'no-method-definition | ||
| 1184 | (list ',method local-args)) | ||
| 1185 | |||
| 1186 | ;; We do have an object. Make sure it is the right type. | ||
| 1187 | (if ,(if (eq class eieio-default-superclass) | ||
| 1188 | nil ; default superclass means just an obj. Already asked. | ||
| 1189 | `(not (child-of-class-p (eieio--object-class (car local-args)) | ||
| 1190 | ',class))) | ||
| 1191 | |||
| 1192 | ;; If not the right kind of object, call no applicable | ||
| 1193 | (apply #'no-applicable-method (car local-args) | ||
| 1194 | ',method local-args) | ||
| 1195 | |||
| 1196 | ;; It is ok, do the call. | ||
| 1197 | ;; Fill in inter-call variables then evaluate the method. | ||
| 1198 | (let ((eieio-generic-call-next-method-list nil) | ||
| 1199 | (eieio-generic-call-key method-primary) | ||
| 1200 | (eieio-generic-call-methodname ',method) | ||
| 1201 | (eieio-generic-call-arglst local-args) | ||
| 1202 | ) | ||
| 1203 | (eieio--with-scoped-class ',class | ||
| 1204 | ,(if (< emacs-major-version 24) | ||
| 1205 | `(apply ,(list 'quote impl) local-args) | ||
| 1206 | `(apply #',impl local-args))) | ||
| 1207 | ;(,impl local-args) | ||
| 1208 | ))))))) | ||
| 1209 | |||
| 1210 | (defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method) | ||
| 1211 | "Setup METHOD to call the generic form." | ||
| 1212 | (let* ((doc-string (documentation method)) | ||
| 1213 | (M (get method 'eieio-method-tree)) | ||
| 1214 | (entry (car (aref M method-primary))) | ||
| 1215 | ) | ||
| 1216 | (fset method (eieio-defgeneric-form-primary-only-one | ||
| 1217 | method doc-string | ||
| 1218 | (car entry) | ||
| 1219 | (cdr entry) | ||
| 1220 | )))) | ||
| 1221 | |||
| 1222 | (defun eieio-unbind-method-implementations (method) | ||
| 1223 | "Make the generic method METHOD have no implementations. | ||
| 1224 | It will leave the original generic function in place, | ||
| 1225 | but remove reference to all implementations of METHOD." | ||
| 1226 | (put method 'eieio-method-tree nil) | ||
| 1227 | (put method 'eieio-method-obarray nil)) | ||
| 1228 | |||
| 1229 | (defun eieio--defmethod (method kind argclass code) | ||
| 1230 | "Work part of the `defmethod' macro defining METHOD with ARGS." | ||
| 1231 | (let ((key | ||
| 1232 | ;; Find optional keys. | ||
| 1233 | (cond ((memq kind '(:BEFORE :before)) method-before) | ||
| 1234 | ((memq kind '(:AFTER :after)) method-after) | ||
| 1235 | ((memq kind '(:STATIC :static)) method-static) | ||
| 1236 | ((memq kind '(:PRIMARY :primary nil)) method-primary) | ||
| 1237 | ;; Primary key. | ||
| 1238 | ;; (t method-primary) | ||
| 1239 | (t (error "Unknown method kind %S" kind))))) | ||
| 1240 | ;; Make sure there is a generic (when called from defclass). | ||
| 1241 | (eieio--defalias | ||
| 1242 | method (eieio--defgeneric-init-form | ||
| 1243 | method (or (documentation code) | ||
| 1244 | (format "Generically created method `%s'." method)))) | ||
| 1245 | ;; Create symbol for property to bind to. If the first arg is of | ||
| 1246 | ;; the form (varname vartype) and `vartype' is a class, then | ||
| 1247 | ;; that class will be the type symbol. If not, then it will fall | ||
| 1248 | ;; under the type `primary' which is a non-specific calling of the | ||
| 1249 | ;; function. | ||
| 1250 | (if argclass | ||
| 1251 | (if (not (class-p argclass)) | ||
| 1252 | (error "Unknown class type %s in method parameters" | ||
| 1253 | argclass)) | ||
| 1254 | ;; Generics are higher. | ||
| 1255 | (setq key (eieio-specialized-key-to-generic-key key))) | ||
| 1256 | ;; Put this lambda into the symbol so we can find it. | ||
| 1257 | (eieiomt-add method code key argclass) | ||
| 1258 | ) | ||
| 1259 | |||
| 1260 | (when eieio-optimize-primary-methods-flag | ||
| 1261 | ;; Optimizing step: | ||
| 1262 | ;; | ||
| 1263 | ;; If this method, after this setup, only has primary methods, then | ||
| 1264 | ;; we can setup the generic that way. | ||
| 1265 | (if (generic-primary-only-p method) | ||
| 1266 | ;; If there is only one primary method, then we can go one more | ||
| 1267 | ;; optimization step. | ||
| 1268 | (if (generic-primary-only-one-p method) | ||
| 1269 | (eieio-defgeneric-reset-generic-form-primary-only-one method) | ||
| 1270 | (eieio-defgeneric-reset-generic-form-primary-only method)) | ||
| 1271 | (eieio-defgeneric-reset-generic-form method))) | ||
| 1272 | |||
| 1273 | method) | ||
| 1274 | |||
| 1275 | ;;; Slot type validation | 917 | ;;; Slot type validation |
| 1276 | 918 | ||
| 1277 | ;; This is a hideous hack for replacing `typep' from cl-macs, to avoid | 919 | ;; This is a hideous hack for replacing `typep' from cl-macs, to avoid |
| 1278 | ;; requiring the CL library at run-time. It can be eliminated if/when | 920 | ;; requiring the CL library at run-time. It can be eliminated if/when |
| 1279 | ;; `typep' is merged into Emacs core. | 921 | ;; `typep' is merged into Emacs core. |
| 1280 | 922 | ||
| 1281 | (defun eieio-perform-slot-validation (spec value) | 923 | (defun eieio--perform-slot-validation (spec value) |
| 1282 | "Return non-nil if SPEC does not match VALUE." | 924 | "Return non-nil if SPEC does not match VALUE." |
| 1283 | (or (eq spec t) ; t always passes | 925 | (or (eq spec t) ; t always passes |
| 1284 | (eq value eieio-unbound) ; unbound always passes | 926 | (eq value eieio-unbound) ; unbound always passes |
| 1285 | (cl-typep value spec))) | 927 | (cl-typep value spec))) |
| 1286 | 928 | ||
| 1287 | (defun eieio-validate-slot-value (class slot-idx value slot) | 929 | (defun eieio--validate-slot-value (class slot-idx value slot) |
| 1288 | "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. | 930 | "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. |
| 1289 | Checks the :type specifier. | 931 | Checks the :type specifier. |
| 1290 | SLOT is the slot that is being checked, and is only used when throwing | 932 | SLOT is the slot that is being checked, and is only used when throwing |
| @@ -1292,22 +934,24 @@ an error." | |||
| 1292 | (if eieio-skip-typecheck | 934 | (if eieio-skip-typecheck |
| 1293 | nil | 935 | nil |
| 1294 | ;; Trim off object IDX junk added in for the object index. | 936 | ;; Trim off object IDX junk added in for the object index. |
| 1295 | (setq slot-idx (- slot-idx 3)) | 937 | (setq slot-idx (- slot-idx (eval-when-compile eieio--object-num-slots))) |
| 1296 | (let ((st (aref (eieio--class-public-type (class-v class)) slot-idx))) | 938 | (let ((st (aref (eieio--class-public-type class) slot-idx))) |
| 1297 | (if (not (eieio-perform-slot-validation st value)) | 939 | (if (not (eieio--perform-slot-validation st value)) |
| 1298 | (signal 'invalid-slot-type (list class slot st value)))))) | 940 | (signal 'invalid-slot-type |
| 941 | (list (eieio--class-symbol class) slot st value)))))) | ||
| 1299 | 942 | ||
| 1300 | (defun eieio-validate-class-slot-value (class slot-idx value slot) | 943 | (defun eieio--validate-class-slot-value (class slot-idx value slot) |
| 1301 | "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. | 944 | "Make sure that for CLASS referencing SLOT-IDX, VALUE is valid. |
| 1302 | Checks the :type specifier. | 945 | Checks the :type specifier. |
| 1303 | SLOT is the slot that is being checked, and is only used when throwing | 946 | SLOT is the slot that is being checked, and is only used when throwing |
| 1304 | an error." | 947 | an error." |
| 1305 | (if eieio-skip-typecheck | 948 | (if eieio-skip-typecheck |
| 1306 | nil | 949 | nil |
| 1307 | (let ((st (aref (eieio--class-class-allocation-type (class-v class)) | 950 | (let ((st (aref (eieio--class-class-allocation-type class) |
| 1308 | slot-idx))) | 951 | slot-idx))) |
| 1309 | (if (not (eieio-perform-slot-validation st value)) | 952 | (if (not (eieio--perform-slot-validation st value)) |
| 1310 | (signal 'invalid-slot-type (list class slot st value)))))) | 953 | (signal 'invalid-slot-type |
| 954 | (list (eieio--class-symbol class) slot st value)))))) | ||
| 1311 | 955 | ||
| 1312 | (defun eieio-barf-if-slot-unbound (value instance slotname fn) | 956 | (defun eieio-barf-if-slot-unbound (value instance slotname fn) |
| 1313 | "Throw a signal if VALUE is a representation of an UNBOUND slot. | 957 | "Throw a signal if VALUE is a representation of an UNBOUND slot. |
| @@ -1315,7 +959,7 @@ INSTANCE is the object being referenced. SLOTNAME is the offending | |||
| 1315 | slot. If the slot is ok, return VALUE. | 959 | slot. If the slot is ok, return VALUE. |
| 1316 | Argument FN is the function calling this verifier." | 960 | Argument FN is the function calling this verifier." |
| 1317 | (if (and (eq value eieio-unbound) (not eieio-skip-typecheck)) | 961 | (if (and (eq value eieio-unbound) (not eieio-skip-typecheck)) |
| 1318 | (slot-unbound instance (eieio--object-class instance) slotname fn) | 962 | (slot-unbound instance (eieio--object-class-name instance) slotname fn) |
| 1319 | value)) | 963 | value)) |
| 1320 | 964 | ||
| 1321 | 965 | ||
| @@ -1326,14 +970,17 @@ Argument FN is the function calling this verifier." | |||
| 1326 | (eieio--check-type (or eieio-object-p class-p) obj) | 970 | (eieio--check-type (or eieio-object-p class-p) obj) |
| 1327 | (eieio--check-type symbolp slot) | 971 | (eieio--check-type symbolp slot) |
| 1328 | (if (class-p obj) (eieio-class-un-autoload obj)) | 972 | (if (class-p obj) (eieio-class-un-autoload obj)) |
| 1329 | (let* ((class (if (class-p obj) obj (eieio--object-class obj))) | 973 | (let* ((class (cond ((symbolp obj) |
| 1330 | (c (eieio-slot-name-index class obj slot))) | 974 | (error "eieio-oref called on a class!") |
| 975 | (eieio--class-v obj)) | ||
| 976 | (t (eieio--object-class-object obj)))) | ||
| 977 | (c (eieio--slot-name-index class obj slot))) | ||
| 1331 | (if (not c) | 978 | (if (not c) |
| 1332 | ;; It might be missing because it is a :class allocated slot. | 979 | ;; It might be missing because it is a :class allocated slot. |
| 1333 | ;; Let's check that info out. | 980 | ;; Let's check that info out. |
| 1334 | (if (setq c (eieio-class-slot-name-index class slot)) | 981 | (if (setq c (eieio--class-slot-name-index class slot)) |
| 1335 | ;; Oref that slot. | 982 | ;; Oref that slot. |
| 1336 | (aref (eieio--class-class-allocation-values (class-v class)) c) | 983 | (aref (eieio--class-class-allocation-values class) c) |
| 1337 | ;; The slot-missing method is a cool way of allowing an object author | 984 | ;; The slot-missing method is a cool way of allowing an object author |
| 1338 | ;; to intercept missing slot definitions. Since it is also the LAST | 985 | ;; to intercept missing slot definitions. Since it is also the LAST |
| 1339 | ;; thing called in this fn, its return value would be retrieved. | 986 | ;; thing called in this fn, its return value would be retrieved. |
| @@ -1349,26 +996,30 @@ Argument FN is the function calling this verifier." | |||
| 1349 | Fills in OBJ's SLOT with its default value." | 996 | Fills in OBJ's SLOT with its default value." |
| 1350 | (eieio--check-type (or eieio-object-p class-p) obj) | 997 | (eieio--check-type (or eieio-object-p class-p) obj) |
| 1351 | (eieio--check-type symbolp slot) | 998 | (eieio--check-type symbolp slot) |
| 1352 | (let* ((cl (if (eieio-object-p obj) (eieio--object-class obj) obj)) | 999 | (let* ((cl (cond ((symbolp obj) (eieio--class-v obj)) |
| 1353 | (c (eieio-slot-name-index cl obj slot))) | 1000 | (t (eieio--object-class-object obj)))) |
| 1001 | (c (eieio--slot-name-index cl obj slot))) | ||
| 1354 | (if (not c) | 1002 | (if (not c) |
| 1355 | ;; It might be missing because it is a :class allocated slot. | 1003 | ;; It might be missing because it is a :class allocated slot. |
| 1356 | ;; Let's check that info out. | 1004 | ;; Let's check that info out. |
| 1357 | (if (setq c | 1005 | (if (setq c |
| 1358 | (eieio-class-slot-name-index cl slot)) | 1006 | (eieio--class-slot-name-index cl slot)) |
| 1359 | ;; Oref that slot. | 1007 | ;; Oref that slot. |
| 1360 | (aref (eieio--class-class-allocation-values (class-v cl)) | 1008 | (aref (eieio--class-class-allocation-values cl) |
| 1361 | c) | 1009 | c) |
| 1362 | (slot-missing obj slot 'oref-default) | 1010 | (slot-missing obj slot 'oref-default) |
| 1363 | ;;(signal 'invalid-slot-name (list (class-name cl) slot)) | 1011 | ;;(signal 'invalid-slot-name (list (class-name cl) slot)) |
| 1364 | ) | 1012 | ) |
| 1365 | (eieio-barf-if-slot-unbound | 1013 | (eieio-barf-if-slot-unbound |
| 1366 | (let ((val (nth (- c 3) (eieio--class-public-d (class-v cl))))) | 1014 | (let ((val (nth (- c (eval-when-compile eieio--object-num-slots)) |
| 1015 | (eieio--class-public-d cl)))) | ||
| 1367 | (eieio-default-eval-maybe val)) | 1016 | (eieio-default-eval-maybe val)) |
| 1368 | obj cl 'oref-default)))) | 1017 | obj (eieio--class-symbol cl) 'oref-default)))) |
| 1369 | 1018 | ||
| 1370 | (defun eieio-default-eval-maybe (val) | 1019 | (defun eieio-default-eval-maybe (val) |
| 1371 | "Check VAL, and return what `oref-default' would provide." | 1020 | "Check VAL, and return what `oref-default' would provide." |
| 1021 | ;; FIXME: What the hell is this supposed to do? Shouldn't it evaluate | ||
| 1022 | ;; variables as well? Why not just always call `eval'? | ||
| 1372 | (cond | 1023 | (cond |
| 1373 | ;; Is it a function call? If so, evaluate it. | 1024 | ;; Is it a function call? If so, evaluate it. |
| 1374 | ((eieio-eval-default-p val) | 1025 | ((eieio-eval-default-p val) |
| @@ -1384,69 +1035,71 @@ Fills in OBJ's SLOT with its default value." | |||
| 1384 | Fills in OBJ's SLOT with VALUE." | 1035 | Fills in OBJ's SLOT with VALUE." |
| 1385 | (eieio--check-type eieio-object-p obj) | 1036 | (eieio--check-type eieio-object-p obj) |
| 1386 | (eieio--check-type symbolp slot) | 1037 | (eieio--check-type symbolp slot) |
| 1387 | (let ((c (eieio-slot-name-index (eieio--object-class obj) obj slot))) | 1038 | (let* ((class (eieio--object-class-object obj)) |
| 1039 | (c (eieio--slot-name-index class obj slot))) | ||
| 1388 | (if (not c) | 1040 | (if (not c) |
| 1389 | ;; It might be missing because it is a :class allocated slot. | 1041 | ;; It might be missing because it is a :class allocated slot. |
| 1390 | ;; Let's check that info out. | 1042 | ;; Let's check that info out. |
| 1391 | (if (setq c | 1043 | (if (setq c |
| 1392 | (eieio-class-slot-name-index (eieio--object-class obj) slot)) | 1044 | (eieio--class-slot-name-index class slot)) |
| 1393 | ;; Oset that slot. | 1045 | ;; Oset that slot. |
| 1394 | (progn | 1046 | (progn |
| 1395 | (eieio-validate-class-slot-value (eieio--object-class obj) c value slot) | 1047 | (eieio--validate-class-slot-value class c value slot) |
| 1396 | (aset (eieio--class-class-allocation-values (class-v (eieio--object-class obj))) | 1048 | (aset (eieio--class-class-allocation-values class) |
| 1397 | c value)) | 1049 | c value)) |
| 1398 | ;; See oref for comment on `slot-missing' | 1050 | ;; See oref for comment on `slot-missing' |
| 1399 | (slot-missing obj slot 'oset value) | 1051 | (slot-missing obj slot 'oset value) |
| 1400 | ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot)) | 1052 | ;;(signal 'invalid-slot-name (list (eieio-object-name obj) slot)) |
| 1401 | ) | 1053 | ) |
| 1402 | (eieio-validate-slot-value (eieio--object-class obj) c value slot) | 1054 | (eieio--validate-slot-value class c value slot) |
| 1403 | (aset obj c value)))) | 1055 | (aset obj c value)))) |
| 1404 | 1056 | ||
| 1405 | (defun eieio-oset-default (class slot value) | 1057 | (defun eieio-oset-default (class slot value) |
| 1406 | "Do the work for the macro `oset-default'. | 1058 | "Do the work for the macro `oset-default'. |
| 1407 | Fills in the default value in CLASS' in SLOT with VALUE." | 1059 | Fills in the default value in CLASS' in SLOT with VALUE." |
| 1408 | (eieio--check-type class-p class) | 1060 | (setq class (eieio--class-object class)) |
| 1061 | (eieio--check-type eieio--class-p class) | ||
| 1409 | (eieio--check-type symbolp slot) | 1062 | (eieio--check-type symbolp slot) |
| 1410 | (eieio--with-scoped-class class | 1063 | (eieio--with-scoped-class class |
| 1411 | (let* ((c (eieio-slot-name-index class nil slot))) | 1064 | (let* ((c (eieio--slot-name-index class nil slot))) |
| 1412 | (if (not c) | 1065 | (if (not c) |
| 1413 | ;; It might be missing because it is a :class allocated slot. | 1066 | ;; It might be missing because it is a :class allocated slot. |
| 1414 | ;; Let's check that info out. | 1067 | ;; Let's check that info out. |
| 1415 | (if (setq c (eieio-class-slot-name-index class slot)) | 1068 | (if (setq c (eieio--class-slot-name-index class slot)) |
| 1416 | (progn | 1069 | (progn |
| 1417 | ;; Oref that slot. | 1070 | ;; Oref that slot. |
| 1418 | (eieio-validate-class-slot-value class c value slot) | 1071 | (eieio--validate-class-slot-value class c value slot) |
| 1419 | (aset (eieio--class-class-allocation-values (class-v class)) c | 1072 | (aset (eieio--class-class-allocation-values class) c |
| 1420 | value)) | 1073 | value)) |
| 1421 | (signal 'invalid-slot-name (list (eieio-class-name class) slot))) | 1074 | (signal 'invalid-slot-name (list (eieio--class-symbol class) slot))) |
| 1422 | (eieio-validate-slot-value class c value slot) | 1075 | (eieio--validate-slot-value class c value slot) |
| 1423 | ;; Set this into the storage for defaults. | 1076 | ;; Set this into the storage for defaults. |
| 1424 | (setcar (nthcdr (- c 3) (eieio--class-public-d (class-v class))) | 1077 | (setcar (nthcdr (- c (eval-when-compile eieio--object-num-slots)) |
| 1078 | (eieio--class-public-d class)) | ||
| 1425 | value) | 1079 | value) |
| 1426 | ;; Take the value, and put it into our cache object. | 1080 | ;; Take the value, and put it into our cache object. |
| 1427 | (eieio-oset (eieio--class-default-object-cache (class-v class)) | 1081 | (eieio-oset (eieio--class-default-object-cache class) |
| 1428 | slot value) | 1082 | slot value) |
| 1429 | )))) | 1083 | )))) |
| 1430 | 1084 | ||
| 1431 | 1085 | ||
| 1432 | ;;; EIEIO internal search functions | 1086 | ;;; EIEIO internal search functions |
| 1433 | ;; | 1087 | ;; |
| 1434 | (defun eieio-slot-originating-class-p (start-class slot) | 1088 | (defun eieio--slot-originating-class-p (start-class slot) |
| 1435 | "Return non-nil if START-CLASS is the first class to define SLOT. | 1089 | "Return non-nil if START-CLASS is the first class to define SLOT. |
| 1436 | This is for testing if the class currently in scope is the class that defines SLOT | 1090 | This is for testing if the class currently in scope is the class that defines SLOT |
| 1437 | so that we can protect private slots." | 1091 | so that we can protect private slots." |
| 1438 | (let ((par (eieio-class-parents-fast start-class)) | 1092 | (let ((par (eieio--class-parent start-class)) |
| 1439 | (ret t)) | 1093 | (ret t)) |
| 1440 | (if (not par) | 1094 | (or (not par) |
| 1441 | t | 1095 | (progn |
| 1442 | (while (and par ret) | 1096 | (while (and par ret) |
| 1443 | (if (intern-soft (symbol-name slot) | 1097 | (if (gethash slot (eieio--class-symbol-hashtable (car par))) |
| 1444 | (eieio--class-symbol-obarray (class-v (car par)))) | 1098 | (setq ret nil)) |
| 1445 | (setq ret nil)) | 1099 | (setq par (cdr par))) |
| 1446 | (setq par (cdr par))) | 1100 | ret)))) |
| 1447 | ret))) | 1101 | |
| 1448 | 1102 | (defun eieio--slot-name-index (class obj slot) | |
| 1449 | (defun eieio-slot-name-index (class obj slot) | ||
| 1450 | "In CLASS for OBJ find the index of the named SLOT. | 1103 | "In CLASS for OBJ find the index of the named SLOT. |
| 1451 | The slot is a symbol which is installed in CLASS by the `defclass' | 1104 | The slot is a symbol which is installed in CLASS by the `defclass' |
| 1452 | call. OBJ can be nil, but if it is an object, and the slot in question | 1105 | call. OBJ can be nil, but if it is an object, and the slot in question |
| @@ -1455,36 +1108,41 @@ scoped class. | |||
| 1455 | If SLOT is the value created with :initarg instead, | 1108 | If SLOT is the value created with :initarg instead, |
| 1456 | reverse-lookup that name, and recurse with the associated slot value." | 1109 | reverse-lookup that name, and recurse with the associated slot value." |
| 1457 | ;; Removed checks to outside this call | 1110 | ;; Removed checks to outside this call |
| 1458 | (let* ((fsym (intern-soft (symbol-name slot) | 1111 | (let* ((fsym (gethash slot (eieio--class-symbol-hashtable class))) |
| 1459 | (eieio--class-symbol-obarray (class-v class)))) | 1112 | (fsi (car fsym))) |
| 1460 | (fsi (if (symbolp fsym) (symbol-value fsym) nil))) | ||
| 1461 | (if (integerp fsi) | 1113 | (if (integerp fsi) |
| 1462 | (cond | 1114 | (cond |
| 1463 | ((not (get fsym 'protection)) | 1115 | ((not (cdr fsym)) |
| 1464 | (+ 3 fsi)) | 1116 | (+ (eval-when-compile eieio--object-num-slots) fsi)) |
| 1465 | ((and (eq (get fsym 'protection) 'protected) | 1117 | ((and (eq (cdr fsym) 'protected) |
| 1466 | (eieio--scoped-class) | 1118 | (eieio--scoped-class) |
| 1467 | (or (child-of-class-p class (eieio--scoped-class)) | 1119 | (or (child-of-class-p class (eieio--scoped-class)) |
| 1468 | (and (eieio-object-p obj) | 1120 | (and (eieio-object-p obj) |
| 1469 | (child-of-class-p class (eieio--object-class obj))))) | 1121 | ;; AFAICT, for all callers, if `obj' is not a class, |
| 1470 | (+ 3 fsi)) | 1122 | ;; then its class is `class'. |
| 1471 | ((and (eq (get fsym 'protection) 'private) | 1123 | ;;(child-of-class-p class (eieio--object-class-object obj)) |
| 1124 | (progn | ||
| 1125 | (cl-assert (eq class (eieio--object-class-object obj))) | ||
| 1126 | t)))) | ||
| 1127 | (+ (eval-when-compile eieio--object-num-slots) fsi)) | ||
| 1128 | ((and (eq (cdr fsym) 'private) | ||
| 1472 | (or (and (eieio--scoped-class) | 1129 | (or (and (eieio--scoped-class) |
| 1473 | (eieio-slot-originating-class-p (eieio--scoped-class) slot)) | 1130 | (eieio--slot-originating-class-p |
| 1131 | (eieio--scoped-class) slot)) | ||
| 1474 | eieio-initializing-object)) | 1132 | eieio-initializing-object)) |
| 1475 | (+ 3 fsi)) | 1133 | (+ (eval-when-compile eieio--object-num-slots) fsi)) |
| 1476 | (t nil)) | 1134 | (t nil)) |
| 1477 | (let ((fn (eieio-initarg-to-attribute class slot))) | 1135 | (let ((fn (eieio--initarg-to-attribute class slot))) |
| 1478 | (if fn (eieio-slot-name-index class obj fn) nil))))) | 1136 | (if fn (eieio--slot-name-index class obj fn) nil))))) |
| 1479 | 1137 | ||
| 1480 | (defun eieio-class-slot-name-index (class slot) | 1138 | (defun eieio--class-slot-name-index (class slot) |
| 1481 | "In CLASS find the index of the named SLOT. | 1139 | "In CLASS find the index of the named SLOT. |
| 1482 | The slot is a symbol which is installed in CLASS by the `defclass' | 1140 | The slot is a symbol which is installed in CLASS by the `defclass' |
| 1483 | call. If SLOT is the value created with :initarg instead, | 1141 | call. If SLOT is the value created with :initarg instead, |
| 1484 | reverse-lookup that name, and recurse with the associated slot value." | 1142 | reverse-lookup that name, and recurse with the associated slot value." |
| 1485 | ;; This will happen less often, and with fewer slots. Do this the | 1143 | ;; This will happen less often, and with fewer slots. Do this the |
| 1486 | ;; storage cheap way. | 1144 | ;; storage cheap way. |
| 1487 | (let* ((a (eieio--class-class-allocation-a (class-v class))) | 1145 | (let* ((a (eieio--class-class-allocation-a class)) |
| 1488 | (l1 (length a)) | 1146 | (l1 (length a)) |
| 1489 | (af (memq slot a)) | 1147 | (af (memq slot a)) |
| 1490 | (l2 (length af))) | 1148 | (l2 (length af))) |
| @@ -1501,36 +1159,28 @@ reverse-lookup that name, and recurse with the associated slot value." | |||
| 1501 | If SET-ALL is non-nil, then when a default is nil, that value is | 1159 | If SET-ALL is non-nil, then when a default is nil, that value is |
| 1502 | reset. If SET-ALL is nil, the slots are only reset if the default is | 1160 | reset. If SET-ALL is nil, the slots are only reset if the default is |
| 1503 | not nil." | 1161 | not nil." |
| 1504 | (eieio--with-scoped-class (eieio--object-class obj) | 1162 | (eieio--with-scoped-class (eieio--object-class-object obj) |
| 1505 | (let ((eieio-initializing-object t) | 1163 | (let ((eieio-initializing-object t) |
| 1506 | (pub (eieio--class-public-a (class-v (eieio--object-class obj))))) | 1164 | (pub (eieio--class-public-a (eieio--object-class-object obj)))) |
| 1507 | (while pub | 1165 | (while pub |
| 1508 | (let ((df (eieio-oref-default obj (car pub)))) | 1166 | (let ((df (eieio-oref-default obj (car pub)))) |
| 1509 | (if (or df set-all) | 1167 | (if (or df set-all) |
| 1510 | (eieio-oset obj (car pub) df))) | 1168 | (eieio-oset obj (car pub) df))) |
| 1511 | (setq pub (cdr pub)))))) | 1169 | (setq pub (cdr pub)))))) |
| 1512 | 1170 | ||
| 1513 | (defun eieio-initarg-to-attribute (class initarg) | 1171 | (defun eieio--initarg-to-attribute (class initarg) |
| 1514 | "For CLASS, convert INITARG to the actual attribute name. | 1172 | "For CLASS, convert INITARG to the actual attribute name. |
| 1515 | If there is no translation, pass it in directly (so we can cheat if | 1173 | If there is no translation, pass it in directly (so we can cheat if |
| 1516 | need be... May remove that later...)" | 1174 | need be... May remove that later...)" |
| 1517 | (let ((tuple (assoc initarg (eieio--class-initarg-tuples (class-v class))))) | 1175 | (let ((tuple (assoc initarg (eieio--class-initarg-tuples class)))) |
| 1518 | (if tuple | 1176 | (if tuple |
| 1519 | (cdr tuple) | 1177 | (cdr tuple) |
| 1520 | nil))) | 1178 | nil))) |
| 1521 | 1179 | ||
| 1522 | (defun eieio-attribute-to-initarg (class attribute) | ||
| 1523 | "In CLASS, convert the ATTRIBUTE into the corresponding init argument tag. | ||
| 1524 | This is usually a symbol that starts with `:'." | ||
| 1525 | (let ((tuple (rassoc attribute (eieio--class-initarg-tuples (class-v class))))) | ||
| 1526 | (if tuple | ||
| 1527 | (car tuple) | ||
| 1528 | nil))) | ||
| 1529 | |||
| 1530 | ;;; | 1180 | ;;; |
| 1531 | ;; Method Invocation order: C3 | 1181 | ;; Method Invocation order: C3 |
| 1532 | (defun eieio-c3-candidate (class remaining-inputs) | 1182 | (defun eieio--c3-candidate (class remaining-inputs) |
| 1533 | "Return CLASS if it can go in the result now, otherwise nil" | 1183 | "Return CLASS if it can go in the result now, otherwise nil." |
| 1534 | ;; Ensure CLASS is not in any position but the first in any of the | 1184 | ;; Ensure CLASS is not in any position but the first in any of the |
| 1535 | ;; element lists of REMAINING-INPUTS. | 1185 | ;; element lists of REMAINING-INPUTS. |
| 1536 | (and (not (let ((found nil)) | 1186 | (and (not (let ((found nil)) |
| @@ -1540,7 +1190,7 @@ This is usually a symbol that starts with `:'." | |||
| 1540 | found)) | 1190 | found)) |
| 1541 | class)) | 1191 | class)) |
| 1542 | 1192 | ||
| 1543 | (defun eieio-c3-merge-lists (reversed-partial-result remaining-inputs) | 1193 | (defun eieio--c3-merge-lists (reversed-partial-result remaining-inputs) |
| 1544 | "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible. | 1194 | "Merge REVERSED-PARTIAL-RESULT REMAINING-INPUTS in a consistent order, if possible. |
| 1545 | If a consistent order does not exist, signal an error." | 1195 | If a consistent order does not exist, signal an error." |
| 1546 | (if (let ((tail remaining-inputs) | 1196 | (if (let ((tail remaining-inputs) |
| @@ -1559,41 +1209,38 @@ If a consistent order does not exist, signal an error." | |||
| 1559 | (next (progn | 1209 | (next (progn |
| 1560 | (while (and tail (not found)) | 1210 | (while (and tail (not found)) |
| 1561 | (setq found (and (car tail) | 1211 | (setq found (and (car tail) |
| 1562 | (eieio-c3-candidate (caar tail) | 1212 | (eieio--c3-candidate (caar tail) |
| 1563 | remaining-inputs)) | 1213 | remaining-inputs)) |
| 1564 | tail (cdr tail))) | 1214 | tail (cdr tail))) |
| 1565 | found))) | 1215 | found))) |
| 1566 | (if next | 1216 | (if next |
| 1567 | ;; The graph is consistent so far, add NEXT to result and | 1217 | ;; The graph is consistent so far, add NEXT to result and |
| 1568 | ;; merge input lists, dropping NEXT from their heads where | 1218 | ;; merge input lists, dropping NEXT from their heads where |
| 1569 | ;; applicable. | 1219 | ;; applicable. |
| 1570 | (eieio-c3-merge-lists | 1220 | (eieio--c3-merge-lists |
| 1571 | (cons next reversed-partial-result) | 1221 | (cons next reversed-partial-result) |
| 1572 | (mapcar (lambda (l) (if (eq (cl-first l) next) (cl-rest l) l)) | 1222 | (mapcar (lambda (l) (if (eq (cl-first l) next) (cl-rest l) l)) |
| 1573 | remaining-inputs)) | 1223 | remaining-inputs)) |
| 1574 | ;; The graph is inconsistent, give up | 1224 | ;; The graph is inconsistent, give up |
| 1575 | (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) | 1225 | (signal 'inconsistent-class-hierarchy (list remaining-inputs)))))) |
| 1576 | 1226 | ||
| 1577 | (defun eieio-class-precedence-c3 (class) | 1227 | (defun eieio--class-precedence-c3 (class) |
| 1578 | "Return all parents of CLASS in c3 order." | 1228 | "Return all parents of CLASS in c3 order." |
| 1579 | (let ((parents (eieio-class-parents-fast class))) | 1229 | (let ((parents (eieio--class-parent (eieio--class-v class)))) |
| 1580 | (eieio-c3-merge-lists | 1230 | (eieio--c3-merge-lists |
| 1581 | (list class) | 1231 | (list class) |
| 1582 | (append | 1232 | (append |
| 1583 | (or | 1233 | (or |
| 1584 | (mapcar | 1234 | (mapcar #'eieio--class-precedence-c3 parents) |
| 1585 | (lambda (x) | 1235 | `((,eieio-default-superclass))) |
| 1586 | (eieio-class-precedence-c3 x)) | ||
| 1587 | parents) | ||
| 1588 | '((eieio-default-superclass))) | ||
| 1589 | (list parents)))) | 1236 | (list parents)))) |
| 1590 | ) | 1237 | ) |
| 1591 | ;;; | 1238 | ;;; |
| 1592 | ;; Method Invocation Order: Depth First | 1239 | ;; Method Invocation Order: Depth First |
| 1593 | 1240 | ||
| 1594 | (defun eieio-class-precedence-dfs (class) | 1241 | (defun eieio--class-precedence-dfs (class) |
| 1595 | "Return all parents of CLASS in depth-first order." | 1242 | "Return all parents of CLASS in depth-first order." |
| 1596 | (let* ((parents (eieio-class-parents-fast class)) | 1243 | (let* ((parents (eieio--class-parent class)) |
| 1597 | (classes (copy-sequence | 1244 | (classes (copy-sequence |
| 1598 | (apply #'append | 1245 | (apply #'append |
| 1599 | (list class) | 1246 | (list class) |
| @@ -1601,9 +1248,9 @@ If a consistent order does not exist, signal an error." | |||
| 1601 | (mapcar | 1248 | (mapcar |
| 1602 | (lambda (parent) | 1249 | (lambda (parent) |
| 1603 | (cons parent | 1250 | (cons parent |
| 1604 | (eieio-class-precedence-dfs parent))) | 1251 | (eieio--class-precedence-dfs parent))) |
| 1605 | parents) | 1252 | parents) |
| 1606 | '((eieio-default-superclass)))))) | 1253 | `((,eieio-default-superclass)))))) |
| 1607 | (tail classes)) | 1254 | (tail classes)) |
| 1608 | ;; Remove duplicates. | 1255 | ;; Remove duplicates. |
| 1609 | (while tail | 1256 | (while tail |
| @@ -1613,563 +1260,55 @@ If a consistent order does not exist, signal an error." | |||
| 1613 | 1260 | ||
| 1614 | ;;; | 1261 | ;;; |
| 1615 | ;; Method Invocation Order: Breadth First | 1262 | ;; Method Invocation Order: Breadth First |
| 1616 | (defun eieio-class-precedence-bfs (class) | 1263 | (defun eieio--class-precedence-bfs (class) |
| 1617 | "Return all parents of CLASS in breadth-first order." | 1264 | "Return all parents of CLASS in breadth-first order." |
| 1618 | (let ((result) | 1265 | (let* ((result) |
| 1619 | (queue (or (eieio-class-parents-fast class) | 1266 | (queue (or (eieio--class-parent class) |
| 1620 | '(eieio-default-superclass)))) | 1267 | `(,eieio-default-superclass)))) |
| 1621 | (while queue | 1268 | (while queue |
| 1622 | (let ((head (pop queue))) | 1269 | (let ((head (pop queue))) |
| 1623 | (unless (member head result) | 1270 | (unless (member head result) |
| 1624 | (push head result) | 1271 | (push head result) |
| 1625 | (unless (eq head 'eieio-default-superclass) | 1272 | (unless (eq head eieio-default-superclass) |
| 1626 | (setq queue (append queue (or (eieio-class-parents-fast head) | 1273 | (setq queue (append queue (or (eieio--class-parent head) |
| 1627 | '(eieio-default-superclass)))))))) | 1274 | `(,eieio-default-superclass)))))))) |
| 1628 | (cons class (nreverse result))) | 1275 | (cons class (nreverse result))) |
| 1629 | ) | 1276 | ) |
| 1630 | 1277 | ||
| 1631 | ;;; | 1278 | ;;; |
| 1632 | ;; Method Invocation Order | 1279 | ;; Method Invocation Order |
| 1633 | 1280 | ||
| 1634 | (defun eieio-class-precedence-list (class) | 1281 | (defun eieio--class-precedence-list (class) |
| 1635 | "Return (transitively closed) list of parents of CLASS. | 1282 | "Return (transitively closed) list of parents of CLASS. |
| 1636 | The order, in which the parents are returned depends on the | 1283 | The order, in which the parents are returned depends on the |
| 1637 | method invocation orders of the involved classes." | 1284 | method invocation orders of the involved classes." |
| 1638 | (if (or (null class) (eq class 'eieio-default-superclass)) | 1285 | (if (or (null class) (eq class eieio-default-superclass)) |
| 1639 | nil | 1286 | nil |
| 1640 | (cl-case (class-method-invocation-order class) | 1287 | (cl-case (eieio--class-method-invocation-order class) |
| 1641 | (:depth-first | 1288 | (:depth-first |
| 1642 | (eieio-class-precedence-dfs class)) | 1289 | (eieio--class-precedence-dfs class)) |
| 1643 | (:breadth-first | 1290 | (:breadth-first |
| 1644 | (eieio-class-precedence-bfs class)) | 1291 | (eieio--class-precedence-bfs class)) |
| 1645 | (:c3 | 1292 | (:c3 |
| 1646 | (eieio-class-precedence-c3 class)))) | 1293 | (eieio--class-precedence-c3 class)))) |
| 1647 | ) | 1294 | ) |
| 1648 | (define-obsolete-function-alias | 1295 | (define-obsolete-function-alias |
| 1649 | 'class-precedence-list 'eieio-class-precedence-list "24.4") | 1296 | 'class-precedence-list 'eieio--class-precedence-list "24.4") |
| 1650 | |||
| 1651 | |||
| 1652 | ;;; CLOS generics internal function handling | ||
| 1653 | ;; | ||
| 1654 | (defvar eieio-generic-call-methodname nil | ||
| 1655 | "When using `call-next-method', provides a context on how to do it.") | ||
| 1656 | (defvar eieio-generic-call-arglst nil | ||
| 1657 | "When using `call-next-method', provides a context for parameters.") | ||
| 1658 | (defvar eieio-generic-call-key nil | ||
| 1659 | "When using `call-next-method', provides a context for the current key. | ||
| 1660 | Keys are a number representing :before, :primary, and :after methods.") | ||
| 1661 | (defvar eieio-generic-call-next-method-list nil | ||
| 1662 | "When executing a PRIMARY or STATIC method, track the 'next-method'. | ||
| 1663 | During executions, the list is first generated, then as each next method | ||
| 1664 | is called, the next method is popped off the stack.") | ||
| 1665 | |||
| 1666 | (define-obsolete-variable-alias 'eieio-pre-method-execution-hooks | ||
| 1667 | 'eieio-pre-method-execution-functions "24.3") | ||
| 1668 | (defvar eieio-pre-method-execution-functions nil | ||
| 1669 | "Abnormal hook run just before an EIEIO method is executed. | ||
| 1670 | The hook function must accept one argument, the list of forms | ||
| 1671 | about to be executed.") | ||
| 1672 | |||
| 1673 | (defun eieio-generic-call (method args) | ||
| 1674 | "Call METHOD with ARGS. | ||
| 1675 | ARGS provides the context on which implementation to use. | ||
| 1676 | This should only be called from a generic function." | ||
| 1677 | ;; We must expand our arguments first as they are always | ||
| 1678 | ;; passed in as quoted symbols | ||
| 1679 | (let ((newargs nil) (mclass nil) (lambdas nil) (tlambdas nil) (keys nil) | ||
| 1680 | (eieio-generic-call-methodname method) | ||
| 1681 | (eieio-generic-call-arglst args) | ||
| 1682 | (firstarg nil) | ||
| 1683 | (primarymethodlist nil)) | ||
| 1684 | ;; get a copy | ||
| 1685 | (setq newargs args | ||
| 1686 | firstarg (car newargs)) | ||
| 1687 | ;; Is the class passed in autoloaded? | ||
| 1688 | ;; Since class names are also constructors, they can be autoloaded | ||
| 1689 | ;; via the autoload command. Check for this, and load them in. | ||
| 1690 | ;; It is ok if it doesn't turn out to be a class. Probably want that | ||
| 1691 | ;; function loaded anyway. | ||
| 1692 | (if (and (symbolp firstarg) | ||
| 1693 | (fboundp firstarg) | ||
| 1694 | (listp (symbol-function firstarg)) | ||
| 1695 | (eq 'autoload (car (symbol-function firstarg)))) | ||
| 1696 | (load (nth 1 (symbol-function firstarg)))) | ||
| 1697 | ;; Determine the class to use. | ||
| 1698 | (cond ((eieio-object-p firstarg) | ||
| 1699 | (setq mclass (eieio--object-class firstarg))) | ||
| 1700 | ((class-p firstarg) | ||
| 1701 | (setq mclass firstarg)) | ||
| 1702 | ) | ||
| 1703 | ;; Make sure the class is a valid class | ||
| 1704 | ;; mclass can be nil (meaning a generic for should be used. | ||
| 1705 | ;; mclass cannot have a value that is not a class, however. | ||
| 1706 | (when (and (not (null mclass)) (not (class-p mclass))) | ||
| 1707 | (error "Cannot dispatch method %S on class %S" | ||
| 1708 | method mclass) | ||
| 1709 | ) | ||
| 1710 | ;; Now create a list in reverse order of all the calls we have | ||
| 1711 | ;; make in order to successfully do this right. Rules: | ||
| 1712 | ;; 1) Only call generics if scoped-class is not defined | ||
| 1713 | ;; This prevents multiple calls in the case of recursion | ||
| 1714 | ;; 2) Only call static if this is a static method. | ||
| 1715 | ;; 3) Only call specifics if the definition allows for them. | ||
| 1716 | ;; 4) Call in order based on :before, :primary, and :after | ||
| 1717 | (when (eieio-object-p firstarg) | ||
| 1718 | ;; Non-static calls do all this stuff. | ||
| 1719 | |||
| 1720 | ;; :after methods | ||
| 1721 | (setq tlambdas | ||
| 1722 | (if mclass | ||
| 1723 | (eieiomt-method-list method method-after mclass) | ||
| 1724 | (list (eieio-generic-form method method-after nil))) | ||
| 1725 | ;;(or (and mclass (eieio-generic-form method method-after mclass)) | ||
| 1726 | ;; (eieio-generic-form method method-after nil)) | ||
| 1727 | ) | ||
| 1728 | (setq lambdas (append tlambdas lambdas) | ||
| 1729 | keys (append (make-list (length tlambdas) method-after) keys)) | ||
| 1730 | |||
| 1731 | ;; :primary methods | ||
| 1732 | (setq tlambdas | ||
| 1733 | (or (and mclass (eieio-generic-form method method-primary mclass)) | ||
| 1734 | (eieio-generic-form method method-primary nil))) | ||
| 1735 | (when tlambdas | ||
| 1736 | (setq lambdas (cons tlambdas lambdas) | ||
| 1737 | keys (cons method-primary keys) | ||
| 1738 | primarymethodlist | ||
| 1739 | (eieiomt-method-list method method-primary mclass))) | ||
| 1740 | |||
| 1741 | ;; :before methods | ||
| 1742 | (setq tlambdas | ||
| 1743 | (if mclass | ||
| 1744 | (eieiomt-method-list method method-before mclass) | ||
| 1745 | (list (eieio-generic-form method method-before nil))) | ||
| 1746 | ;;(or (and mclass (eieio-generic-form method method-before mclass)) | ||
| 1747 | ;; (eieio-generic-form method method-before nil)) | ||
| 1748 | ) | ||
| 1749 | (setq lambdas (append tlambdas lambdas) | ||
| 1750 | keys (append (make-list (length tlambdas) method-before) keys)) | ||
| 1751 | ) | ||
| 1752 | |||
| 1753 | (if mclass | ||
| 1754 | ;; For the case of a class, | ||
| 1755 | ;; if there were no methods found, then there could be :static methods. | ||
| 1756 | (when (not lambdas) | ||
| 1757 | (setq tlambdas | ||
| 1758 | (eieio-generic-form method method-static mclass)) | ||
| 1759 | (setq lambdas (cons tlambdas lambdas) | ||
| 1760 | keys (cons method-static keys) | ||
| 1761 | primarymethodlist ;; Re-use even with bad name here | ||
| 1762 | (eieiomt-method-list method method-static mclass))) | ||
| 1763 | ;; For the case of no class (ie - mclass == nil) then there may | ||
| 1764 | ;; be a primary method. | ||
| 1765 | (setq tlambdas | ||
| 1766 | (eieio-generic-form method method-primary nil)) | ||
| 1767 | (when tlambdas | ||
| 1768 | (setq lambdas (cons tlambdas lambdas) | ||
| 1769 | keys (cons method-primary keys) | ||
| 1770 | primarymethodlist | ||
| 1771 | (eieiomt-method-list method method-primary nil))) | ||
| 1772 | ) | ||
| 1773 | |||
| 1774 | (run-hook-with-args 'eieio-pre-method-execution-functions | ||
| 1775 | primarymethodlist) | ||
| 1776 | |||
| 1777 | ;; Now loop through all occurrences forms which we must execute | ||
| 1778 | ;; (which are happily sorted now) and execute them all! | ||
| 1779 | (let ((rval nil) (lastval nil) (found nil)) | ||
| 1780 | (while lambdas | ||
| 1781 | (if (car lambdas) | ||
| 1782 | (eieio--with-scoped-class (cdr (car lambdas)) | ||
| 1783 | (let* ((eieio-generic-call-key (car keys)) | ||
| 1784 | (has-return-val | ||
| 1785 | (or (= eieio-generic-call-key method-primary) | ||
| 1786 | (= eieio-generic-call-key method-static))) | ||
| 1787 | (eieio-generic-call-next-method-list | ||
| 1788 | ;; Use the cdr, as the first element is the fcn | ||
| 1789 | ;; we are calling right now. | ||
| 1790 | (when has-return-val (cdr primarymethodlist))) | ||
| 1791 | ) | ||
| 1792 | (setq found t) | ||
| 1793 | ;;(setq rval (apply (car (car lambdas)) newargs)) | ||
| 1794 | (setq lastval (apply (car (car lambdas)) newargs)) | ||
| 1795 | (when has-return-val | ||
| 1796 | (setq rval lastval)) | ||
| 1797 | ))) | ||
| 1798 | (setq lambdas (cdr lambdas) | ||
| 1799 | keys (cdr keys))) | ||
| 1800 | (if (not found) | ||
| 1801 | (if (eieio-object-p (car args)) | ||
| 1802 | (setq rval (apply #'no-applicable-method (car args) method args)) | ||
| 1803 | (signal | ||
| 1804 | 'no-method-definition | ||
| 1805 | (list method args)))) | ||
| 1806 | rval))) | ||
| 1807 | |||
| 1808 | (defun eieio-generic-call-primary-only (method args) | ||
| 1809 | "Call METHOD with ARGS for methods with only :PRIMARY implementations. | ||
| 1810 | ARGS provides the context on which implementation to use. | ||
| 1811 | This should only be called from a generic function. | ||
| 1812 | |||
| 1813 | This method is like `eieio-generic-call', but only | ||
| 1814 | implementations in the :PRIMARY slot are queried. After many | ||
| 1815 | years of use, it appears that over 90% of methods in use | ||
| 1816 | have :PRIMARY implementations only. We can therefore optimize | ||
| 1817 | for this common case to improve performance." | ||
| 1818 | ;; We must expand our arguments first as they are always | ||
| 1819 | ;; passed in as quoted symbols | ||
| 1820 | (let ((newargs nil) (mclass nil) (lambdas nil) | ||
| 1821 | (eieio-generic-call-methodname method) | ||
| 1822 | (eieio-generic-call-arglst args) | ||
| 1823 | (firstarg nil) | ||
| 1824 | (primarymethodlist nil) | ||
| 1825 | ) | ||
| 1826 | ;; get a copy | ||
| 1827 | (setq newargs args | ||
| 1828 | firstarg (car newargs)) | ||
| 1829 | |||
| 1830 | ;; Determine the class to use. | ||
| 1831 | (cond ((eieio-object-p firstarg) | ||
| 1832 | (setq mclass (eieio--object-class firstarg))) | ||
| 1833 | ((not firstarg) | ||
| 1834 | (error "Method %s called on nil" method)) | ||
| 1835 | ((not (eieio-object-p firstarg)) | ||
| 1836 | (error "Primary-only method %s called on something not an object" method)) | ||
| 1837 | (t | ||
| 1838 | (error "EIEIO Error: Improperly classified method %s as primary only" | ||
| 1839 | method) | ||
| 1840 | )) | ||
| 1841 | ;; Make sure the class is a valid class | ||
| 1842 | ;; mclass can be nil (meaning a generic for should be used. | ||
| 1843 | ;; mclass cannot have a value that is not a class, however. | ||
| 1844 | (when (null mclass) | ||
| 1845 | (error "Cannot dispatch method %S on class %S" method mclass) | ||
| 1846 | ) | ||
| 1847 | |||
| 1848 | ;; :primary methods | ||
| 1849 | (setq lambdas (eieio-generic-form method method-primary mclass)) | ||
| 1850 | (setq primarymethodlist ;; Re-use even with bad name here | ||
| 1851 | (eieiomt-method-list method method-primary mclass)) | ||
| 1852 | |||
| 1853 | ;; Now loop through all occurrences forms which we must execute | ||
| 1854 | ;; (which are happily sorted now) and execute them all! | ||
| 1855 | (eieio--with-scoped-class (cdr lambdas) | ||
| 1856 | (let* ((rval nil) (lastval nil) | ||
| 1857 | (eieio-generic-call-key method-primary) | ||
| 1858 | ;; Use the cdr, as the first element is the fcn | ||
| 1859 | ;; we are calling right now. | ||
| 1860 | (eieio-generic-call-next-method-list (cdr primarymethodlist)) | ||
| 1861 | ) | ||
| 1862 | |||
| 1863 | (if (or (not lambdas) (not (car lambdas))) | ||
| 1864 | |||
| 1865 | ;; No methods found for this impl... | ||
| 1866 | (if (eieio-object-p (car args)) | ||
| 1867 | (setq rval (apply #'no-applicable-method | ||
| 1868 | (car args) method args)) | ||
| 1869 | (signal | ||
| 1870 | 'no-method-definition | ||
| 1871 | (list method args))) | ||
| 1872 | |||
| 1873 | ;; Do the regular implementation here. | ||
| 1874 | |||
| 1875 | (run-hook-with-args 'eieio-pre-method-execution-functions | ||
| 1876 | lambdas) | ||
| 1877 | |||
| 1878 | (setq lastval (apply (car lambdas) newargs)) | ||
| 1879 | (setq rval lastval)) | ||
| 1880 | |||
| 1881 | rval)))) | ||
| 1882 | |||
| 1883 | (defun eieiomt-method-list (method key class) | ||
| 1884 | "Return an alist list of methods lambdas. | ||
| 1885 | METHOD is the method name. | ||
| 1886 | KEY represents either :before, or :after methods. | ||
| 1887 | CLASS is the starting class to search from in the method tree. | ||
| 1888 | If CLASS is nil, then an empty list of methods should be returned." | ||
| 1889 | ;; Note: eieiomt - the MT means MethodTree. See more comments below | ||
| 1890 | ;; for the rest of the eieiomt methods. | ||
| 1891 | |||
| 1892 | ;; Collect lambda expressions stored for the class and its parent | ||
| 1893 | ;; classes. | ||
| 1894 | (let (lambdas) | ||
| 1895 | (dolist (ancestor (eieio-class-precedence-list class)) | ||
| 1896 | ;; Lookup the form to use for the PRIMARY object for the next level | ||
| 1897 | (let ((tmpl (eieio-generic-form method key ancestor))) | ||
| 1898 | (when (and tmpl | ||
| 1899 | (or (not lambdas) | ||
| 1900 | ;; This prevents duplicates coming out of the | ||
| 1901 | ;; class method optimizer. Perhaps we should | ||
| 1902 | ;; just not optimize before/afters? | ||
| 1903 | (not (member tmpl lambdas)))) | ||
| 1904 | (push tmpl lambdas)))) | ||
| 1905 | |||
| 1906 | ;; Return collected lambda. For :after methods, return in current | ||
| 1907 | ;; order (most general class last); Otherwise, reverse order. | ||
| 1908 | (if (eq key method-after) | ||
| 1909 | lambdas | ||
| 1910 | (nreverse lambdas)))) | ||
| 1911 | |||
| 1912 | |||
| 1913 | ;;; | ||
| 1914 | ;; eieio-method-tree : eieiomt- | ||
| 1915 | ;; | ||
| 1916 | ;; Stored as eieio-method-tree in property list of a generic method | ||
| 1917 | ;; | ||
| 1918 | ;; (eieio-method-tree . [BEFORE PRIMARY AFTER | ||
| 1919 | ;; genericBEFORE genericPRIMARY genericAFTER]) | ||
| 1920 | ;; and | ||
| 1921 | ;; (eieio-method-obarray . [BEFORE PRIMARY AFTER | ||
| 1922 | ;; genericBEFORE genericPRIMARY genericAFTER]) | ||
| 1923 | ;; where the association is a vector. | ||
| 1924 | ;; (aref 0 -- all static methods. | ||
| 1925 | ;; (aref 1 -- all methods classified as :before | ||
| 1926 | ;; (aref 2 -- all methods classified as :primary | ||
| 1927 | ;; (aref 3 -- all methods classified as :after | ||
| 1928 | ;; (aref 4 -- a generic classified as :before | ||
| 1929 | ;; (aref 5 -- a generic classified as :primary | ||
| 1930 | ;; (aref 6 -- a generic classified as :after | ||
| 1931 | ;; | ||
| 1932 | (defvar eieiomt-optimizing-obarray nil | ||
| 1933 | "While mapping atoms, this contain the obarray being optimized.") | ||
| 1934 | |||
| 1935 | (defun eieiomt-install (method-name) | ||
| 1936 | "Install the method tree, and obarray onto METHOD-NAME. | ||
| 1937 | Do not do the work if they already exist." | ||
| 1938 | (let ((emtv (get method-name 'eieio-method-tree)) | ||
| 1939 | (emto (get method-name 'eieio-method-obarray))) | ||
| 1940 | (if (or (not emtv) (not emto)) | ||
| 1941 | (progn | ||
| 1942 | (setq emtv (put method-name 'eieio-method-tree | ||
| 1943 | (make-vector method-num-slots nil)) | ||
| 1944 | emto (put method-name 'eieio-method-obarray | ||
| 1945 | (make-vector method-num-slots nil))) | ||
| 1946 | (aset emto 0 (make-vector 11 0)) | ||
| 1947 | (aset emto 1 (make-vector 11 0)) | ||
| 1948 | (aset emto 2 (make-vector 41 0)) | ||
| 1949 | (aset emto 3 (make-vector 11 0)) | ||
| 1950 | )))) | ||
| 1951 | |||
| 1952 | (defun eieiomt-add (method-name method key class) | ||
| 1953 | "Add to METHOD-NAME the forms METHOD in a call position KEY for CLASS. | ||
| 1954 | METHOD-NAME is the name created by a call to `defgeneric'. | ||
| 1955 | METHOD are the forms for a given implementation. | ||
| 1956 | KEY is an integer (see comment in eieio.el near this function) which | ||
| 1957 | is associated with the :static :before :primary and :after tags. | ||
| 1958 | It also indicates if CLASS is defined or not. | ||
| 1959 | CLASS is the class this method is associated with." | ||
| 1960 | (if (or (> key method-num-slots) (< key 0)) | ||
| 1961 | (error "eieiomt-add: method key error!")) | ||
| 1962 | (let ((emtv (get method-name 'eieio-method-tree)) | ||
| 1963 | (emto (get method-name 'eieio-method-obarray))) | ||
| 1964 | ;; Make sure the method tables are available. | ||
| 1965 | (if (or (not emtv) (not emto)) | ||
| 1966 | (error "Programmer error: eieiomt-add")) | ||
| 1967 | ;; only add new cells on if it doesn't already exist! | ||
| 1968 | (if (assq class (aref emtv key)) | ||
| 1969 | (setcdr (assq class (aref emtv key)) method) | ||
| 1970 | (aset emtv key (cons (cons class method) (aref emtv key)))) | ||
| 1971 | ;; Add function definition into newly created symbol, and store | ||
| 1972 | ;; said symbol in the correct obarray, otherwise use the | ||
| 1973 | ;; other array to keep this stuff | ||
| 1974 | (if (< key method-num-lists) | ||
| 1975 | (let ((nsym (intern (symbol-name class) (aref emto key)))) | ||
| 1976 | (fset nsym method))) | ||
| 1977 | ;; Save the defmethod file location in a symbol property. | ||
| 1978 | (let ((fname (if load-in-progress | ||
| 1979 | load-file-name | ||
| 1980 | buffer-file-name)) | ||
| 1981 | loc) | ||
| 1982 | (when fname | ||
| 1983 | (when (string-match "\\.elc$" fname) | ||
| 1984 | (setq fname (substring fname 0 (1- (length fname))))) | ||
| 1985 | (setq loc (get method-name 'method-locations)) | ||
| 1986 | (cl-pushnew (list class fname) loc :test 'equal) | ||
| 1987 | (put method-name 'method-locations loc))) | ||
| 1988 | ;; Now optimize the entire obarray | ||
| 1989 | (if (< key method-num-lists) | ||
| 1990 | (let ((eieiomt-optimizing-obarray (aref emto key))) | ||
| 1991 | ;; @todo - Is this overkill? Should we just clear the symbol? | ||
| 1992 | (mapatoms 'eieiomt-sym-optimize eieiomt-optimizing-obarray))) | ||
| 1993 | )) | ||
| 1994 | |||
| 1995 | (defun eieiomt-next (class) | ||
| 1996 | "Return the next parent class for CLASS. | ||
| 1997 | If CLASS is a superclass, return variable `eieio-default-superclass'. | ||
| 1998 | If CLASS is variable `eieio-default-superclass' then return nil. | ||
| 1999 | This is different from function `class-parent' as class parent returns | ||
| 2000 | nil for superclasses. This function performs no type checking!" | ||
| 2001 | ;; No type-checking because all calls are made from functions which | ||
| 2002 | ;; are safe and do checking for us. | ||
| 2003 | (or (eieio-class-parents-fast class) | ||
| 2004 | (if (eq class 'eieio-default-superclass) | ||
| 2005 | nil | ||
| 2006 | '(eieio-default-superclass)))) | ||
| 2007 | |||
| 2008 | (defun eieiomt-sym-optimize (s) | ||
| 2009 | "Find the next class above S which has a function body for the optimizer." | ||
| 2010 | ;; Set the value to nil in case there is no nearest cell. | ||
| 2011 | (set s nil) | ||
| 2012 | ;; Find the nearest cell that has a function body. If we find one, | ||
| 2013 | ;; we replace the nil from above. | ||
| 2014 | (let ((external-symbol (intern-soft (symbol-name s)))) | ||
| 2015 | (catch 'done | ||
| 2016 | (dolist (ancestor | ||
| 2017 | (cl-rest (eieio-class-precedence-list external-symbol))) | ||
| 2018 | (let ((ov (intern-soft (symbol-name ancestor) | ||
| 2019 | eieiomt-optimizing-obarray))) | ||
| 2020 | (when (fboundp ov) | ||
| 2021 | (set s ov) ;; store ov as our next symbol | ||
| 2022 | (throw 'done ancestor))))))) | ||
| 2023 | |||
| 2024 | (defun eieio-generic-form (method key class) | ||
| 2025 | "Return the lambda form belonging to METHOD using KEY based upon CLASS. | ||
| 2026 | If CLASS is not a class then use `generic' instead. If class has | ||
| 2027 | no form, but has a parent class, then trace to that parent class. | ||
| 2028 | The first time a form is requested from a symbol, an optimized path | ||
| 2029 | is memorized for faster future use." | ||
| 2030 | (let ((emto (aref (get method 'eieio-method-obarray) | ||
| 2031 | (if class key (eieio-specialized-key-to-generic-key key))))) | ||
| 2032 | (if (class-p class) | ||
| 2033 | ;; 1) find our symbol | ||
| 2034 | (let ((cs (intern-soft (symbol-name class) emto))) | ||
| 2035 | (if (not cs) | ||
| 2036 | ;; 2) If there isn't one, then make one. | ||
| 2037 | ;; This can be slow since it only occurs once | ||
| 2038 | (progn | ||
| 2039 | (setq cs (intern (symbol-name class) emto)) | ||
| 2040 | ;; 2.1) Cache its nearest neighbor with a quick optimize | ||
| 2041 | ;; which should only occur once for this call ever | ||
| 2042 | (let ((eieiomt-optimizing-obarray emto)) | ||
| 2043 | (eieiomt-sym-optimize cs)))) | ||
| 2044 | ;; 3) If it's bound return this one. | ||
| 2045 | (if (fboundp cs) | ||
| 2046 | (cons cs (eieio--class-symbol (class-v class))) | ||
| 2047 | ;; 4) If it's not bound then this variable knows something | ||
| 2048 | (if (symbol-value cs) | ||
| 2049 | (progn | ||
| 2050 | ;; 4.1) This symbol holds the next class in its value | ||
| 2051 | (setq class (symbol-value cs) | ||
| 2052 | cs (intern-soft (symbol-name class) emto)) | ||
| 2053 | ;; 4.2) The optimizer should always have chosen a | ||
| 2054 | ;; function-symbol | ||
| 2055 | ;;(if (fboundp cs) | ||
| 2056 | (cons cs (eieio--class-symbol (class-v (intern (symbol-name class))))) | ||
| 2057 | ;;(error "EIEIO optimizer: erratic data loss!")) | ||
| 2058 | ) | ||
| 2059 | ;; There never will be a funcall... | ||
| 2060 | nil))) | ||
| 2061 | ;; for a generic call, what is a list, is the function body we want. | ||
| 2062 | (let ((emtl (aref (get method 'eieio-method-tree) | ||
| 2063 | (if class key (eieio-specialized-key-to-generic-key key))))) | ||
| 2064 | (if emtl | ||
| 2065 | ;; The car of EMTL is supposed to be a class, which in this | ||
| 2066 | ;; case is nil, so skip it. | ||
| 2067 | (cons (cdr (car emtl)) nil) | ||
| 2068 | nil))))) | ||
| 2069 | 1297 | ||
| 2070 | 1298 | ||
| 2071 | ;;; Here are some special types of errors | 1299 | ;;; Here are some special types of errors |
| 2072 | ;; | 1300 | ;; |
| 2073 | (define-error 'no-method-definition "No method definition") | ||
| 2074 | (define-error 'no-next-method "No next method") | ||
| 2075 | (define-error 'invalid-slot-name "Invalid slot name") | 1301 | (define-error 'invalid-slot-name "Invalid slot name") |
| 2076 | (define-error 'invalid-slot-type "Invalid slot type") | 1302 | (define-error 'invalid-slot-type "Invalid slot type") |
| 2077 | (define-error 'unbound-slot "Unbound slot") | 1303 | (define-error 'unbound-slot "Unbound slot") |
| 2078 | (define-error 'inconsistent-class-hierarchy "Inconsistent class hierarchy") | 1304 | (define-error 'inconsistent-class-hierarchy "Inconsistent class hierarchy") |
| 2079 | 1305 | ||
| 2080 | ;;; Obsolete backward compatibility functions. | 1306 | ;;; Backward compatibility functions |
| 2081 | ;; Needed to run byte-code compiled with the EIEIO of Emacs-23. | 1307 | ;; To support .elc files compiled for older versions of EIEIO. |
| 2082 | 1308 | ||
| 2083 | (defun eieio-defmethod (method args) | 1309 | (defun eieio-defclass (cname superclasses slots options) |
| 2084 | "Obsolete work part of an old version of the `defmethod' macro." | 1310 | (eval `(defclass ,cname ,superclasses ,slots ,options))) |
| 2085 | (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) | 1311 | |
| 2086 | ;; find optional keys | ||
| 2087 | (setq key | ||
| 2088 | (cond ((memq (car args) '(:BEFORE :before)) | ||
| 2089 | (setq args (cdr args)) | ||
| 2090 | method-before) | ||
| 2091 | ((memq (car args) '(:AFTER :after)) | ||
| 2092 | (setq args (cdr args)) | ||
| 2093 | method-after) | ||
| 2094 | ((memq (car args) '(:STATIC :static)) | ||
| 2095 | (setq args (cdr args)) | ||
| 2096 | method-static) | ||
| 2097 | ((memq (car args) '(:PRIMARY :primary)) | ||
| 2098 | (setq args (cdr args)) | ||
| 2099 | method-primary) | ||
| 2100 | ;; Primary key. | ||
| 2101 | (t method-primary))) | ||
| 2102 | ;; Get body, and fix contents of args to be the arguments of the fn. | ||
| 2103 | (setq body (cdr args) | ||
| 2104 | args (car args)) | ||
| 2105 | (setq loopa args) | ||
| 2106 | ;; Create a fixed version of the arguments. | ||
| 2107 | (while loopa | ||
| 2108 | (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa)) | ||
| 2109 | argfix)) | ||
| 2110 | (setq loopa (cdr loopa))) | ||
| 2111 | ;; Make sure there is a generic. | ||
| 2112 | (eieio-defgeneric | ||
| 2113 | method | ||
| 2114 | (if (stringp (car body)) | ||
| 2115 | (car body) (format "Generically created method `%s'." method))) | ||
| 2116 | ;; create symbol for property to bind to. If the first arg is of | ||
| 2117 | ;; the form (varname vartype) and `vartype' is a class, then | ||
| 2118 | ;; that class will be the type symbol. If not, then it will fall | ||
| 2119 | ;; under the type `primary' which is a non-specific calling of the | ||
| 2120 | ;; function. | ||
| 2121 | (setq firstarg (car args)) | ||
| 2122 | (if (listp firstarg) | ||
| 2123 | (progn | ||
| 2124 | (setq argclass (nth 1 firstarg)) | ||
| 2125 | (if (not (class-p argclass)) | ||
| 2126 | (error "Unknown class type %s in method parameters" | ||
| 2127 | (nth 1 firstarg)))) | ||
| 2128 | ;; Generics are higher. | ||
| 2129 | (setq key (eieio-specialized-key-to-generic-key key))) | ||
| 2130 | ;; Put this lambda into the symbol so we can find it. | ||
| 2131 | (if (byte-code-function-p (car-safe body)) | ||
| 2132 | (eieiomt-add method (car-safe body) key argclass) | ||
| 2133 | (eieiomt-add method (append (list 'lambda (reverse argfix)) body) | ||
| 2134 | key argclass)) | ||
| 2135 | ) | ||
| 2136 | |||
| 2137 | (when eieio-optimize-primary-methods-flag | ||
| 2138 | ;; Optimizing step: | ||
| 2139 | ;; | ||
| 2140 | ;; If this method, after this setup, only has primary methods, then | ||
| 2141 | ;; we can setup the generic that way. | ||
| 2142 | (if (generic-primary-only-p method) | ||
| 2143 | ;; If there is only one primary method, then we can go one more | ||
| 2144 | ;; optimization step. | ||
| 2145 | (if (generic-primary-only-one-p method) | ||
| 2146 | (eieio-defgeneric-reset-generic-form-primary-only-one method) | ||
| 2147 | (eieio-defgeneric-reset-generic-form-primary-only method)) | ||
| 2148 | (eieio-defgeneric-reset-generic-form method))) | ||
| 2149 | |||
| 2150 | method) | ||
| 2151 | (make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1") | ||
| 2152 | |||
| 2153 | (defun eieio-defgeneric (method doc-string) | ||
| 2154 | "Obsolete work part of an old version of the `defgeneric' macro." | ||
| 2155 | (if (and (fboundp method) (not (generic-p method)) | ||
| 2156 | (or (byte-code-function-p (symbol-function method)) | ||
| 2157 | (not (eq 'autoload (car (symbol-function method))))) | ||
| 2158 | ) | ||
| 2159 | (error "You cannot create a generic/method over an existing symbol: %s" | ||
| 2160 | method)) | ||
| 2161 | ;; Don't do this over and over. | ||
| 2162 | (unless (fboundp 'method) | ||
| 2163 | ;; This defun tells emacs where the first definition of this | ||
| 2164 | ;; method is defined. | ||
| 2165 | `(defun ,method nil) | ||
| 2166 | ;; Make sure the method tables are installed. | ||
| 2167 | (eieiomt-install method) | ||
| 2168 | ;; Apply the actual body of this function. | ||
| 2169 | (fset method (eieio-defgeneric-form method doc-string)) | ||
| 2170 | ;; Return the method | ||
| 2171 | 'method)) | ||
| 2172 | (make-obsolete 'eieio-defgeneric nil "24.1") | ||
| 2173 | 1312 | ||
| 2174 | (provide 'eieio-core) | 1313 | (provide 'eieio-core) |
| 2175 | 1314 | ||
diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index dc85b4cc892..d0eaaf24d2b 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; eieio-custom.el -- eieio object customization | 1 | ;;; eieio-custom.el -- eieio object customization -*- lexical-binding:t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1999-2001, 2005, 2007-2015 Free Software Foundation, | 3 | ;; Copyright (C) 1999-2001, 2005, 2007-2015 Free Software Foundation, |
| 4 | ;; Inc. | 4 | ;; Inc. |
| @@ -70,7 +70,7 @@ of these.") | |||
| 70 | :documentation "A number of thingies.")) | 70 | :documentation "A number of thingies.")) |
| 71 | "A class for testing the widget on.") | 71 | "A class for testing the widget on.") |
| 72 | 72 | ||
| 73 | (defcustom eieio-widget-test (eieio-widget-test-class "Foo") | 73 | (defcustom eieio-widget-test (eieio-widget-test-class) |
| 74 | "Test variable for editing an object." | 74 | "Test variable for editing an object." |
| 75 | :type 'object | 75 | :type 'object |
| 76 | :group 'eieio) | 76 | :group 'eieio) |
| @@ -136,7 +136,7 @@ Updates occur regardless of the current customization group.") | |||
| 136 | )) | 136 | )) |
| 137 | (widget-value-set vc (widget-value vc)))) | 137 | (widget-value-set vc (widget-value vc)))) |
| 138 | 138 | ||
| 139 | (defun eieio-custom-toggle-parent (widget &rest ignore) | 139 | (defun eieio-custom-toggle-parent (widget &rest _) |
| 140 | "Toggle visibility of parent of WIDGET. | 140 | "Toggle visibility of parent of WIDGET. |
| 141 | Optional argument IGNORE is an extraneous parameter." | 141 | Optional argument IGNORE is an extraneous parameter." |
| 142 | (eieio-custom-toggle-hide (widget-get widget :parent))) | 142 | (eieio-custom-toggle-hide (widget-get widget :parent))) |
| @@ -154,7 +154,7 @@ Optional argument IGNORE is an extraneous parameter." | |||
| 154 | :clone-object-children nil | 154 | :clone-object-children nil |
| 155 | ) | 155 | ) |
| 156 | 156 | ||
| 157 | (defun eieio-object-match (widget value) | 157 | (defun eieio-object-match (_widget _value) |
| 158 | "Match info for WIDGET against VALUE." | 158 | "Match info for WIDGET against VALUE." |
| 159 | ;; Write me | 159 | ;; Write me |
| 160 | t) | 160 | t) |
| @@ -193,7 +193,7 @@ Optional argument IGNORE is an extraneous parameter." | |||
| 193 | (let* ((chil nil) | 193 | (let* ((chil nil) |
| 194 | (obj (widget-get widget :value)) | 194 | (obj (widget-get widget :value)) |
| 195 | (master-group (widget-get widget :eieio-group)) | 195 | (master-group (widget-get widget :eieio-group)) |
| 196 | (cv (class-v (eieio--object-class obj))) | 196 | (cv (eieio--object-class-object obj)) |
| 197 | (slots (eieio--class-public-a cv)) | 197 | (slots (eieio--class-public-a cv)) |
| 198 | (flabel (eieio--class-public-custom-label cv)) | 198 | (flabel (eieio--class-public-custom-label cv)) |
| 199 | (fgroup (eieio--class-public-custom-group cv)) | 199 | (fgroup (eieio--class-public-custom-group cv)) |
| @@ -208,7 +208,8 @@ Optional argument IGNORE is an extraneous parameter." | |||
| 208 | chil))) | 208 | chil))) |
| 209 | ;; Display information about the group being shown | 209 | ;; Display information about the group being shown |
| 210 | (when master-group | 210 | (when master-group |
| 211 | (let ((groups (class-option (eieio--object-class obj) :custom-groups))) | 211 | (let ((groups (eieio--class-option (eieio--object-class-object obj) |
| 212 | :custom-groups))) | ||
| 212 | (widget-insert "Groups:") | 213 | (widget-insert "Groups:") |
| 213 | (while groups | 214 | (while groups |
| 214 | (widget-insert " ") | 215 | (widget-insert " ") |
| @@ -216,7 +217,7 @@ Optional argument IGNORE is an extraneous parameter." | |||
| 216 | (widget-insert "*" (capitalize (symbol-name master-group)) "*") | 217 | (widget-insert "*" (capitalize (symbol-name master-group)) "*") |
| 217 | (widget-create 'push-button | 218 | (widget-create 'push-button |
| 218 | :thing (cons obj (car groups)) | 219 | :thing (cons obj (car groups)) |
| 219 | :notify (lambda (widget &rest stuff) | 220 | :notify (lambda (widget &rest _) |
| 220 | (eieio-customize-object | 221 | (eieio-customize-object |
| 221 | (car (widget-get widget :thing)) | 222 | (car (widget-get widget :thing)) |
| 222 | (cdr (widget-get widget :thing)))) | 223 | (cdr (widget-get widget :thing)))) |
| @@ -260,8 +261,8 @@ Optional argument IGNORE is an extraneous parameter." | |||
| 260 | (car flabel) | 261 | (car flabel) |
| 261 | (let ((s (symbol-name | 262 | (let ((s (symbol-name |
| 262 | (or | 263 | (or |
| 263 | (class-slot-initarg | 264 | (eieio--class-slot-initarg |
| 264 | (eieio--object-class obj) | 265 | (eieio--object-class-object obj) |
| 265 | (car slots)) | 266 | (car slots)) |
| 266 | (car slots))))) | 267 | (car slots))))) |
| 267 | (capitalize | 268 | (capitalize |
| @@ -288,7 +289,7 @@ Optional argument IGNORE is an extraneous parameter." | |||
| 288 | "Get the value of WIDGET." | 289 | "Get the value of WIDGET." |
| 289 | (let* ((obj (widget-get widget :value)) | 290 | (let* ((obj (widget-get widget :value)) |
| 290 | (master-group eieio-cog) | 291 | (master-group eieio-cog) |
| 291 | (cv (class-v (eieio--object-class obj))) | 292 | (cv (eieio--object-class-object obj)) |
| 292 | (fgroup (eieio--class-public-custom-group cv)) | 293 | (fgroup (eieio--class-public-custom-group cv)) |
| 293 | (wids (widget-get widget :children)) | 294 | (wids (widget-get widget :children)) |
| 294 | (name (if (widget-get widget :eieio-show-name) | 295 | (name (if (widget-get widget :eieio-show-name) |
| @@ -296,7 +297,7 @@ Optional argument IGNORE is an extraneous parameter." | |||
| 296 | nil)) | 297 | nil)) |
| 297 | (chil (if (widget-get widget :eieio-show-name) | 298 | (chil (if (widget-get widget :eieio-show-name) |
| 298 | (nthcdr 1 wids) wids)) | 299 | (nthcdr 1 wids) wids)) |
| 299 | (cv (class-v (eieio--object-class obj))) | 300 | (cv (eieio--object-class-object obj)) |
| 300 | (slots (eieio--class-public-a cv)) | 301 | (slots (eieio--class-public-a cv)) |
| 301 | (fcust (eieio--class-public-custom cv))) | 302 | (fcust (eieio--class-public-custom cv))) |
| 302 | ;; If there are any prefix widgets, clear them. | 303 | ;; If there are any prefix widgets, clear them. |
| @@ -317,11 +318,11 @@ Optional argument IGNORE is an extraneous parameter." | |||
| 317 | fgroup (cdr fgroup) | 318 | fgroup (cdr fgroup) |
| 318 | fcust (cdr fcust))) | 319 | fcust (cdr fcust))) |
| 319 | ;; Set any name updates on it. | 320 | ;; Set any name updates on it. |
| 320 | (if name (setf (eieio--object-name obj) name)) | 321 | (if name (eieio-object-set-name-string obj name)) |
| 321 | ;; This is the same object we had before. | 322 | ;; This is the same object we had before. |
| 322 | obj)) | 323 | obj)) |
| 323 | 324 | ||
| 324 | (defmethod eieio-done-customizing ((obj eieio-default-superclass)) | 325 | (defmethod eieio-done-customizing ((_obj eieio-default-superclass)) |
| 325 | "When applying change to a widget, call this method. | 326 | "When applying change to a widget, call this method. |
| 326 | This method is called by the default widget-edit commands. | 327 | This method is called by the default widget-edit commands. |
| 327 | User made commands should also call this method when applying changes. | 328 | User made commands should also call this method when applying changes. |
| @@ -385,18 +386,18 @@ These groups are specified with the `:group' slot flag." | |||
| 385 | (make-local-variable 'eieio-cog) | 386 | (make-local-variable 'eieio-cog) |
| 386 | (setq eieio-cog g))) | 387 | (setq eieio-cog g))) |
| 387 | 388 | ||
| 388 | (defmethod eieio-custom-object-apply-reset ((obj eieio-default-superclass)) | 389 | (defmethod eieio-custom-object-apply-reset ((_obj eieio-default-superclass)) |
| 389 | "Insert an Apply and Reset button into the object editor. | 390 | "Insert an Apply and Reset button into the object editor. |
| 390 | Argument OBJ is the object being customized." | 391 | Argument OBJ is the object being customized." |
| 391 | (widget-create 'push-button | 392 | (widget-create 'push-button |
| 392 | :notify (lambda (&rest ignore) | 393 | :notify (lambda (&rest _) |
| 393 | (widget-apply eieio-wo :value-get) | 394 | (widget-apply eieio-wo :value-get) |
| 394 | (eieio-done-customizing eieio-co) | 395 | (eieio-done-customizing eieio-co) |
| 395 | (bury-buffer)) | 396 | (bury-buffer)) |
| 396 | "Accept") | 397 | "Accept") |
| 397 | (widget-insert " ") | 398 | (widget-insert " ") |
| 398 | (widget-create 'push-button | 399 | (widget-create 'push-button |
| 399 | :notify (lambda (&rest ignore) | 400 | :notify (lambda (&rest _) |
| 400 | ;; I think the act of getting it sets | 401 | ;; I think the act of getting it sets |
| 401 | ;; its value through the get function. | 402 | ;; its value through the get function. |
| 402 | (message "Applying Changes...") | 403 | (message "Applying Changes...") |
| @@ -406,13 +407,13 @@ Argument OBJ is the object being customized." | |||
| 406 | "Apply") | 407 | "Apply") |
| 407 | (widget-insert " ") | 408 | (widget-insert " ") |
| 408 | (widget-create 'push-button | 409 | (widget-create 'push-button |
| 409 | :notify (lambda (&rest ignore) | 410 | :notify (lambda (&rest _) |
| 410 | (message "Resetting") | 411 | (message "Resetting") |
| 411 | (eieio-customize-object eieio-co eieio-cog)) | 412 | (eieio-customize-object eieio-co eieio-cog)) |
| 412 | "Reset") | 413 | "Reset") |
| 413 | (widget-insert " ") | 414 | (widget-insert " ") |
| 414 | (widget-create 'push-button | 415 | (widget-create 'push-button |
| 415 | :notify (lambda (&rest ignore) | 416 | :notify (lambda (&rest _) |
| 416 | (bury-buffer)) | 417 | (bury-buffer)) |
| 417 | "Cancel")) | 418 | "Cancel")) |
| 418 | 419 | ||
| @@ -431,13 +432,11 @@ Must return the created widget." | |||
| 431 | :clone-object-children t | 432 | :clone-object-children t |
| 432 | ) | 433 | ) |
| 433 | 434 | ||
| 434 | (defun eieio-object-value-to-abstract (widget value) | 435 | (defun eieio-object-value-to-abstract (_widget value) |
| 435 | "For WIDGET, convert VALUE to an abstract /safe/ representation." | 436 | "For WIDGET, convert VALUE to an abstract /safe/ representation." |
| 436 | (if (eieio-object-p value) value | 437 | (if (eieio-object-p value) value)) |
| 437 | (if (null value) value | ||
| 438 | nil))) | ||
| 439 | 438 | ||
| 440 | (defun eieio-object-abstract-to-value (widget value) | 439 | (defun eieio-object-abstract-to-value (_widget value) |
| 441 | "For WIDGET, convert VALUE from an abstract /safe/ representation." | 440 | "For WIDGET, convert VALUE from an abstract /safe/ representation." |
| 442 | value) | 441 | value) |
| 443 | 442 | ||
| @@ -453,7 +452,7 @@ Must return the created widget." | |||
| 453 | (vector (concat "Group " (symbol-name group)) | 452 | (vector (concat "Group " (symbol-name group)) |
| 454 | (list 'customize-object obj (list 'quote group)) | 453 | (list 'customize-object obj (list 'quote group)) |
| 455 | t)) | 454 | t)) |
| 456 | (class-option (eieio--object-class obj) :custom-groups))) | 455 | (eieio--class-option (eieio--object-class-object obj) :custom-groups))) |
| 457 | 456 | ||
| 458 | (defvar eieio-read-custom-group-history nil | 457 | (defvar eieio-read-custom-group-history nil |
| 459 | "History for the custom group reader.") | 458 | "History for the custom group reader.") |
| @@ -461,7 +460,8 @@ Must return the created widget." | |||
| 461 | (defmethod eieio-read-customization-group ((obj eieio-default-superclass)) | 460 | (defmethod eieio-read-customization-group ((obj eieio-default-superclass)) |
| 462 | "Do a completing read on the name of a customization group in OBJ. | 461 | "Do a completing read on the name of a customization group in OBJ. |
| 463 | Return the symbol for the group, or nil" | 462 | Return the symbol for the group, or nil" |
| 464 | (let ((g (class-option (eieio--object-class obj) :custom-groups))) | 463 | (let ((g (eieio--class-option (eieio--object-class-object obj) |
| 464 | :custom-groups))) | ||
| 465 | (if (= (length g) 1) | 465 | (if (= (length g) 1) |
| 466 | (car g) | 466 | (car g) |
| 467 | ;; Make the association list | 467 | ;; Make the association list |
diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index 0a51ecfa203..43d9a03932a 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; eieio-datadebug.el --- EIEIO extensions to the data debugger. | 1 | ;;; eieio-datadebug.el --- EIEIO extensions to the data debugger. -*- lexical-binding:t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 2007-2015 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 2007-2015 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -87,7 +87,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button." | |||
| 87 | prefix | 87 | prefix |
| 88 | "Name: ") | 88 | "Name: ") |
| 89 | (let* ((cl (eieio-object-class obj)) | 89 | (let* ((cl (eieio-object-class obj)) |
| 90 | (cv (class-v cl))) | 90 | (cv (eieio--class-v cl))) |
| 91 | (data-debug-insert-thing (class-constructor cl) | 91 | (data-debug-insert-thing (class-constructor cl) |
| 92 | prefix | 92 | prefix |
| 93 | "Class: ") | 93 | "Class: ") |
| @@ -96,7 +96,8 @@ PREBUTTONTEXT is some text between PREFIX and the object button." | |||
| 96 | ) | 96 | ) |
| 97 | (while publa | 97 | (while publa |
| 98 | (if (slot-boundp obj (car publa)) | 98 | (if (slot-boundp obj (car publa)) |
| 99 | (let* ((i (class-slot-initarg cl (car publa))) | 99 | (let* ((i (eieio--class-slot-initarg (eieio--class-v cl) |
| 100 | (car publa))) | ||
| 100 | (v (eieio-oref obj (car publa)))) | 101 | (v (eieio-oref obj (car publa)))) |
| 101 | (data-debug-insert-thing | 102 | (data-debug-insert-thing |
| 102 | v prefix (concat | 103 | v prefix (concat |
| @@ -104,7 +105,8 @@ PREBUTTONTEXT is some text between PREFIX and the object button." | |||
| 104 | (symbol-name (car publa))) | 105 | (symbol-name (car publa))) |
| 105 | " "))) | 106 | " "))) |
| 106 | ;; Unbound case | 107 | ;; Unbound case |
| 107 | (let ((i (class-slot-initarg cl (car publa)))) | 108 | (let ((i (eieio--class-slot-initarg (eieio--class-v cl) |
| 109 | (car publa)))) | ||
| 108 | (data-debug-insert-custom | 110 | (data-debug-insert-custom |
| 109 | "#unbound" prefix | 111 | "#unbound" prefix |
| 110 | (concat (if i (symbol-name i) | 112 | (concat (if i (symbol-name i) |
| @@ -135,9 +137,9 @@ PREBUTTONTEXT is some text between PREFIX and the object button." | |||
| 135 | (let* ((eieio-pre-method-execution-functions | 137 | (let* ((eieio-pre-method-execution-functions |
| 136 | (lambda (l) (throw 'moose l) )) | 138 | (lambda (l) (throw 'moose l) )) |
| 137 | (data | 139 | (data |
| 138 | (catch 'moose (eieio-generic-call | 140 | (catch 'moose (eieio--generic-call |
| 139 | method (list class)))) | 141 | method (list class)))) |
| 140 | (buf (data-debug-new-buffer "*Method Invocation*")) | 142 | (_buf (data-debug-new-buffer "*Method Invocation*")) |
| 141 | (data2 (mapcar (lambda (sym) | 143 | (data2 (mapcar (lambda (sym) |
| 142 | (symbol-function (car sym))) | 144 | (symbol-function (car sym))) |
| 143 | data))) | 145 | data))) |
diff --git a/lisp/emacs-lisp/eieio-generic.el b/lisp/emacs-lisp/eieio-generic.el new file mode 100644 index 00000000000..0e90074660e --- /dev/null +++ b/lisp/emacs-lisp/eieio-generic.el | |||
| @@ -0,0 +1,904 @@ | |||
| 1 | ;;; eieio-generic.el --- CLOS-style generics for EIEIO -*- lexical-binding:t -*- | ||
| 2 | |||
| 3 | ;; Copyright (C) 1995-1996, 1998-2015 Free Software Foundation, Inc. | ||
| 4 | |||
| 5 | ;; Author: Eric M. Ludlam <zappo@gnu.org> | ||
| 6 | ;; Keywords: OO, lisp | ||
| 7 | |||
| 8 | ;; This file is part of GNU Emacs. | ||
| 9 | |||
| 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify | ||
| 11 | ;; it under the terms of the GNU General Public License as published by | ||
| 12 | ;; the Free Software Foundation, either version 3 of the License, or | ||
| 13 | ;; (at your option) any later version. | ||
| 14 | |||
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, | ||
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 18 | ;; GNU General Public License for more details. | ||
| 19 | |||
| 20 | ;; You should have received a copy of the GNU General Public License | ||
| 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. | ||
| 22 | |||
| 23 | ;;; Commentary: | ||
| 24 | ;; | ||
| 25 | ;; The "core" part of EIEIO is the implementation for the object | ||
| 26 | ;; system (such as eieio-defclass, or eieio-defmethod) but not the | ||
| 27 | ;; base classes for the object system, which are defined in EIEIO. | ||
| 28 | ;; | ||
| 29 | ;; See the commentary for eieio.el for more about EIEIO itself. | ||
| 30 | |||
| 31 | ;;; Code: | ||
| 32 | |||
| 33 | (require 'eieio-core) | ||
| 34 | (declare-function child-of-class-p "eieio") | ||
| 35 | |||
| 36 | (defconst eieio--method-static 0 "Index into :static tag on a method.") | ||
| 37 | (defconst eieio--method-before 1 "Index into :before tag on a method.") | ||
| 38 | (defconst eieio--method-primary 2 "Index into :primary tag on a method.") | ||
| 39 | (defconst eieio--method-after 3 "Index into :after tag on a method.") | ||
| 40 | (defconst eieio--method-num-lists 4 "Number of indexes into methods vector in which groups of functions are kept.") | ||
| 41 | (defconst eieio--method-generic-before 4 "Index into generic :before tag on a method.") | ||
| 42 | (defconst eieio--method-generic-primary 5 "Index into generic :primary tag on a method.") | ||
| 43 | (defconst eieio--method-generic-after 6 "Index into generic :after tag on a method.") | ||
| 44 | (defconst eieio--method-num-slots 7 "Number of indexes into a method's vector.") | ||
| 45 | |||
| 46 | (defsubst eieio--specialized-key-to-generic-key (key) | ||
| 47 | "Convert a specialized KEY into a generic method key." | ||
| 48 | (cond ((eq key eieio--method-static) 0) ;; don't convert | ||
| 49 | ((< key eieio--method-num-lists) (+ key 3)) ;; The conversion | ||
| 50 | (t key) ;; already generic.. maybe. | ||
| 51 | )) | ||
| 52 | |||
| 53 | |||
| 54 | (defsubst generic-p (method) | ||
| 55 | "Return non-nil if symbol METHOD is a generic function. | ||
| 56 | Only methods have the symbol `eieio-method-hashtable' as a property | ||
| 57 | \(which contains a list of all bindings to that method type.)" | ||
| 58 | (and (fboundp method) (get method 'eieio-method-hashtable))) | ||
| 59 | |||
| 60 | (defun eieio--generic-primary-only-p (method) | ||
| 61 | "Return t if symbol METHOD is a generic function with only primary methods. | ||
| 62 | Only methods have the symbol `eieio-method-hashtable' as a property (which | ||
| 63 | contains a list of all bindings to that method type.) | ||
| 64 | Methods with only primary implementations are executed in an optimized way." | ||
| 65 | (and (generic-p method) | ||
| 66 | (let ((M (get method 'eieio-method-tree))) | ||
| 67 | (not (or (>= 0 (length (aref M eieio--method-primary))) | ||
| 68 | (aref M eieio--method-static) | ||
| 69 | (aref M eieio--method-before) | ||
| 70 | (aref M eieio--method-after) | ||
| 71 | (aref M eieio--method-generic-before) | ||
| 72 | (aref M eieio--method-generic-primary) | ||
| 73 | (aref M eieio--method-generic-after))) | ||
| 74 | ))) | ||
| 75 | |||
| 76 | (defun eieio--generic-primary-only-one-p (method) | ||
| 77 | "Return t if symbol METHOD is a generic function with only primary methods. | ||
| 78 | Only methods have the symbol `eieio-method-hashtable' as a property (which | ||
| 79 | contains a list of all bindings to that method type.) | ||
| 80 | Methods with only primary implementations are executed in an optimized way." | ||
| 81 | (and (generic-p method) | ||
| 82 | (let ((M (get method 'eieio-method-tree))) | ||
| 83 | (not (or (/= 1 (length (aref M eieio--method-primary))) | ||
| 84 | (aref M eieio--method-static) | ||
| 85 | (aref M eieio--method-before) | ||
| 86 | (aref M eieio--method-after) | ||
| 87 | (aref M eieio--method-generic-before) | ||
| 88 | (aref M eieio--method-generic-primary) | ||
| 89 | (aref M eieio--method-generic-after))) | ||
| 90 | ))) | ||
| 91 | |||
| 92 | (defun eieio--defgeneric-init-form (method doc-string) | ||
| 93 | "Form to use for the initial definition of a generic." | ||
| 94 | (while (and (fboundp method) (symbolp (symbol-function method))) | ||
| 95 | ;; Follow aliases, so methods applied to obsolete aliases still work. | ||
| 96 | (setq method (symbol-function method))) | ||
| 97 | |||
| 98 | (cond | ||
| 99 | ((or (not (fboundp method)) | ||
| 100 | (eq 'autoload (car-safe (symbol-function method)))) | ||
| 101 | ;; Make sure the method tables are installed. | ||
| 102 | (eieio--mt-install method) | ||
| 103 | ;; Construct the actual body of this function. | ||
| 104 | (put method 'function-documentation doc-string) | ||
| 105 | (eieio--defgeneric-form method)) | ||
| 106 | ((generic-p method) (symbol-function method)) ;Leave it as-is. | ||
| 107 | (t (error "You cannot create a generic/method over an existing symbol: %s" | ||
| 108 | method)))) | ||
| 109 | |||
| 110 | (defun eieio--defgeneric-form (method) | ||
| 111 | "The lambda form that would be used as the function defined on METHOD. | ||
| 112 | All methods should call the same EIEIO function for dispatch. | ||
| 113 | DOC-STRING is the documentation attached to METHOD." | ||
| 114 | (lambda (&rest local-args) | ||
| 115 | (eieio--generic-call method local-args))) | ||
| 116 | |||
| 117 | (defun eieio--defgeneric-form-primary-only (method) | ||
| 118 | "The lambda form that would be used as the function defined on METHOD. | ||
| 119 | All methods should call the same EIEIO function for dispatch. | ||
| 120 | DOC-STRING is the documentation attached to METHOD." | ||
| 121 | (lambda (&rest local-args) | ||
| 122 | (eieio--generic-call-primary-only method local-args))) | ||
| 123 | |||
| 124 | (defvar eieio--generic-call-arglst nil | ||
| 125 | "When using `call-next-method', provides a context for parameters.") | ||
| 126 | (defvar eieio--generic-call-key nil | ||
| 127 | "When using `call-next-method', provides a context for the current key. | ||
| 128 | Keys are a number representing :before, :primary, and :after methods.") | ||
| 129 | (defvar eieio--generic-call-next-method-list nil | ||
| 130 | "When executing a PRIMARY or STATIC method, track the 'next-method'. | ||
| 131 | During executions, the list is first generated, then as each next method | ||
| 132 | is called, the next method is popped off the stack.") | ||
| 133 | |||
| 134 | (defun eieio--defgeneric-form-primary-only-one (method class impl) | ||
| 135 | "The lambda form that would be used as the function defined on METHOD. | ||
| 136 | All methods should call the same EIEIO function for dispatch. | ||
| 137 | CLASS is the class symbol needed for private method access. | ||
| 138 | IMPL is the symbol holding the method implementation." | ||
| 139 | (lambda (&rest local-args) | ||
| 140 | ;; This is a cool cheat. Usually we need to look up in the | ||
| 141 | ;; method table to find out if there is a method or not. We can | ||
| 142 | ;; instead make that determination at load time when there is | ||
| 143 | ;; only one method. If the first arg is not a child of the class | ||
| 144 | ;; of that one implementation, then clearly, there is no method def. | ||
| 145 | (if (not (eieio-object-p (car local-args))) | ||
| 146 | ;; Not an object. Just signal. | ||
| 147 | (signal 'no-method-definition | ||
| 148 | (list method local-args)) | ||
| 149 | |||
| 150 | ;; We do have an object. Make sure it is the right type. | ||
| 151 | (if (not (child-of-class-p (eieio--object-class-object (car local-args)) | ||
| 152 | class)) | ||
| 153 | |||
| 154 | ;; If not the right kind of object, call no applicable | ||
| 155 | (apply #'no-applicable-method (car local-args) | ||
| 156 | method local-args) | ||
| 157 | |||
| 158 | ;; It is ok, do the call. | ||
| 159 | ;; Fill in inter-call variables then evaluate the method. | ||
| 160 | (let ((eieio--generic-call-next-method-list nil) | ||
| 161 | (eieio--generic-call-key eieio--method-primary) | ||
| 162 | (eieio--generic-call-arglst local-args) | ||
| 163 | ) | ||
| 164 | (eieio--with-scoped-class (eieio--class-v class) | ||
| 165 | (apply impl local-args))))))) | ||
| 166 | |||
| 167 | (defun eieio-unbind-method-implementations (method) | ||
| 168 | "Make the generic method METHOD have no implementations. | ||
| 169 | It will leave the original generic function in place, | ||
| 170 | but remove reference to all implementations of METHOD." | ||
| 171 | (put method 'eieio-method-tree nil) | ||
| 172 | (put method 'eieio-method-hashtable nil)) | ||
| 173 | |||
| 174 | (defun eieio--method-optimize-primary (method) | ||
| 175 | (when eieio-optimize-primary-methods-flag | ||
| 176 | ;; Optimizing step: | ||
| 177 | ;; | ||
| 178 | ;; If this method, after this setup, only has primary methods, then | ||
| 179 | ;; we can setup the generic that way. | ||
| 180 | (let ((doc-string (documentation method 'raw))) | ||
| 181 | (put method 'function-documentation doc-string) | ||
| 182 | ;; Use `defalias' so as to interact properly with nadvice.el. | ||
| 183 | (defalias method | ||
| 184 | (if (eieio--generic-primary-only-p method) | ||
| 185 | ;; If there is only one primary method, then we can go one more | ||
| 186 | ;; optimization step. | ||
| 187 | (if (eieio--generic-primary-only-one-p method) | ||
| 188 | (let* ((M (get method 'eieio-method-tree)) | ||
| 189 | (entry (car (aref M eieio--method-primary)))) | ||
| 190 | (eieio--defgeneric-form-primary-only-one | ||
| 191 | method (car entry) (cdr entry))) | ||
| 192 | (eieio--defgeneric-form-primary-only method)) | ||
| 193 | (eieio--defgeneric-form method)))))) | ||
| 194 | |||
| 195 | (defun eieio--defmethod (method kind argclass code) | ||
| 196 | "Work part of the `defmethod' macro defining METHOD with ARGS." | ||
| 197 | (let ((key | ||
| 198 | ;; Find optional keys. | ||
| 199 | (cond ((memq kind '(:BEFORE :before)) eieio--method-before) | ||
| 200 | ((memq kind '(:AFTER :after)) eieio--method-after) | ||
| 201 | ((memq kind '(:STATIC :static)) eieio--method-static) | ||
| 202 | ((memq kind '(:PRIMARY :primary nil)) eieio--method-primary) | ||
| 203 | ;; Primary key. | ||
| 204 | ;; (t eieio--method-primary) | ||
| 205 | (t (error "Unknown method kind %S" kind))))) | ||
| 206 | |||
| 207 | (while (and (fboundp method) (symbolp (symbol-function method))) | ||
| 208 | ;; Follow aliases, so methods applied to obsolete aliases still work. | ||
| 209 | (setq method (symbol-function method))) | ||
| 210 | |||
| 211 | ;; Make sure there is a generic (when called from defclass). | ||
| 212 | (eieio--defalias | ||
| 213 | method (eieio--defgeneric-init-form | ||
| 214 | method (or (documentation code) | ||
| 215 | (format "Generically created method `%s'." method)))) | ||
| 216 | ;; Create symbol for property to bind to. If the first arg is of | ||
| 217 | ;; the form (varname vartype) and `vartype' is a class, then | ||
| 218 | ;; that class will be the type symbol. If not, then it will fall | ||
| 219 | ;; under the type `primary' which is a non-specific calling of the | ||
| 220 | ;; function. | ||
| 221 | (if argclass | ||
| 222 | (if (not (class-p argclass)) ;FIXME: Accept cl-defstructs! | ||
| 223 | (error "Unknown class type %s in method parameters" | ||
| 224 | argclass)) | ||
| 225 | ;; Generics are higher. | ||
| 226 | (setq key (eieio--specialized-key-to-generic-key key))) | ||
| 227 | ;; Put this lambda into the symbol so we can find it. | ||
| 228 | (eieio--mt-add method code key argclass) | ||
| 229 | ) | ||
| 230 | |||
| 231 | (eieio--method-optimize-primary method) | ||
| 232 | |||
| 233 | method) | ||
| 234 | |||
| 235 | (define-obsolete-variable-alias 'eieio-pre-method-execution-hooks | ||
| 236 | 'eieio-pre-method-execution-functions "24.3") | ||
| 237 | (defvar eieio-pre-method-execution-functions nil | ||
| 238 | "Abnormal hook run just before an EIEIO method is executed. | ||
| 239 | The hook function must accept one argument, the list of forms | ||
| 240 | about to be executed.") | ||
| 241 | |||
| 242 | (defun eieio--generic-call (method args) | ||
| 243 | "Call METHOD with ARGS. | ||
| 244 | ARGS provides the context on which implementation to use. | ||
| 245 | This should only be called from a generic function." | ||
| 246 | ;; We must expand our arguments first as they are always | ||
| 247 | ;; passed in as quoted symbols | ||
| 248 | (let ((newargs nil) (mclass nil) (lambdas nil) (tlambdas nil) (keys nil) | ||
| 249 | (eieio--generic-call-arglst args) | ||
| 250 | (firstarg nil) | ||
| 251 | (primarymethodlist nil)) | ||
| 252 | ;; get a copy | ||
| 253 | (setq newargs args | ||
| 254 | firstarg (car newargs)) | ||
| 255 | ;; Is the class passed in autoloaded? | ||
| 256 | ;; Since class names are also constructors, they can be autoloaded | ||
| 257 | ;; via the autoload command. Check for this, and load them in. | ||
| 258 | ;; It is ok if it doesn't turn out to be a class. Probably want that | ||
| 259 | ;; function loaded anyway. | ||
| 260 | (if (and (symbolp firstarg) | ||
| 261 | (fboundp firstarg) | ||
| 262 | (autoloadp (symbol-function firstarg))) | ||
| 263 | (autoload-do-load (symbol-function firstarg))) | ||
| 264 | ;; Determine the class to use. | ||
| 265 | (cond ((eieio-object-p firstarg) | ||
| 266 | (setq mclass (eieio--object-class-name firstarg))) | ||
| 267 | ((class-p firstarg) | ||
| 268 | (setq mclass firstarg)) | ||
| 269 | ) | ||
| 270 | ;; Make sure the class is a valid class | ||
| 271 | ;; mclass can be nil (meaning a generic for should be used. | ||
| 272 | ;; mclass cannot have a value that is not a class, however. | ||
| 273 | (unless (or (null mclass) (class-p mclass)) | ||
| 274 | (error "Cannot dispatch method %S on class %S" | ||
| 275 | method mclass) | ||
| 276 | ) | ||
| 277 | ;; Now create a list in reverse order of all the calls we have | ||
| 278 | ;; make in order to successfully do this right. Rules: | ||
| 279 | ;; 1) Only call generics if scoped-class is not defined | ||
| 280 | ;; This prevents multiple calls in the case of recursion | ||
| 281 | ;; 2) Only call static if this is a static method. | ||
| 282 | ;; 3) Only call specifics if the definition allows for them. | ||
| 283 | ;; 4) Call in order based on :before, :primary, and :after | ||
| 284 | (when (eieio-object-p firstarg) | ||
| 285 | ;; Non-static calls do all this stuff. | ||
| 286 | |||
| 287 | ;; :after methods | ||
| 288 | (setq tlambdas | ||
| 289 | (if mclass | ||
| 290 | (eieio--mt-method-list method eieio--method-after mclass) | ||
| 291 | (list (eieio--generic-form method eieio--method-after nil))) | ||
| 292 | ;;(or (and mclass (eieio--generic-form method eieio--method-after mclass)) | ||
| 293 | ;; (eieio--generic-form method eieio--method-after nil)) | ||
| 294 | ) | ||
| 295 | (setq lambdas (append tlambdas lambdas) | ||
| 296 | keys (append (make-list (length tlambdas) eieio--method-after) keys)) | ||
| 297 | |||
| 298 | ;; :primary methods | ||
| 299 | (setq tlambdas | ||
| 300 | (or (and mclass (eieio--generic-form method eieio--method-primary mclass)) | ||
| 301 | (eieio--generic-form method eieio--method-primary nil))) | ||
| 302 | (when tlambdas | ||
| 303 | (setq lambdas (cons tlambdas lambdas) | ||
| 304 | keys (cons eieio--method-primary keys) | ||
| 305 | primarymethodlist | ||
| 306 | (eieio--mt-method-list method eieio--method-primary mclass))) | ||
| 307 | |||
| 308 | ;; :before methods | ||
| 309 | (setq tlambdas | ||
| 310 | (if mclass | ||
| 311 | (eieio--mt-method-list method eieio--method-before mclass) | ||
| 312 | (list (eieio--generic-form method eieio--method-before nil))) | ||
| 313 | ;;(or (and mclass (eieio--generic-form method eieio--method-before mclass)) | ||
| 314 | ;; (eieio--generic-form method eieio--method-before nil)) | ||
| 315 | ) | ||
| 316 | (setq lambdas (append tlambdas lambdas) | ||
| 317 | keys (append (make-list (length tlambdas) eieio--method-before) keys)) | ||
| 318 | ) | ||
| 319 | |||
| 320 | (if mclass | ||
| 321 | ;; For the case of a class, | ||
| 322 | ;; if there were no methods found, then there could be :static methods. | ||
| 323 | (when (not lambdas) | ||
| 324 | (setq tlambdas | ||
| 325 | (eieio--generic-form method eieio--method-static mclass)) | ||
| 326 | (setq lambdas (cons tlambdas lambdas) | ||
| 327 | keys (cons eieio--method-static keys) | ||
| 328 | primarymethodlist ;; Re-use even with bad name here | ||
| 329 | (eieio--mt-method-list method eieio--method-static mclass))) | ||
| 330 | ;; For the case of no class (ie - mclass == nil) then there may | ||
| 331 | ;; be a primary method. | ||
| 332 | (setq tlambdas | ||
| 333 | (eieio--generic-form method eieio--method-primary nil)) | ||
| 334 | (when tlambdas | ||
| 335 | (setq lambdas (cons tlambdas lambdas) | ||
| 336 | keys (cons eieio--method-primary keys) | ||
| 337 | primarymethodlist | ||
| 338 | (eieio--mt-method-list method eieio--method-primary nil))) | ||
| 339 | ) | ||
| 340 | |||
| 341 | (run-hook-with-args 'eieio-pre-method-execution-functions | ||
| 342 | primarymethodlist) | ||
| 343 | |||
| 344 | ;; Now loop through all occurrences forms which we must execute | ||
| 345 | ;; (which are happily sorted now) and execute them all! | ||
| 346 | (let ((rval nil) (lastval nil) (found nil)) | ||
| 347 | (while lambdas | ||
| 348 | (if (car lambdas) | ||
| 349 | (eieio--with-scoped-class (cdr (car lambdas)) | ||
| 350 | (let* ((eieio--generic-call-key (car keys)) | ||
| 351 | (has-return-val | ||
| 352 | (or (= eieio--generic-call-key eieio--method-primary) | ||
| 353 | (= eieio--generic-call-key eieio--method-static))) | ||
| 354 | (eieio--generic-call-next-method-list | ||
| 355 | ;; Use the cdr, as the first element is the fcn | ||
| 356 | ;; we are calling right now. | ||
| 357 | (when has-return-val (cdr primarymethodlist))) | ||
| 358 | ) | ||
| 359 | (setq found t) | ||
| 360 | ;;(setq rval (apply (car (car lambdas)) newargs)) | ||
| 361 | (setq lastval (apply (car (car lambdas)) newargs)) | ||
| 362 | (when has-return-val | ||
| 363 | (setq rval lastval)) | ||
| 364 | ))) | ||
| 365 | (setq lambdas (cdr lambdas) | ||
| 366 | keys (cdr keys))) | ||
| 367 | (if (not found) | ||
| 368 | (if (eieio-object-p (car args)) | ||
| 369 | (setq rval (apply #'no-applicable-method (car args) method args)) | ||
| 370 | (signal | ||
| 371 | 'no-method-definition | ||
| 372 | (list method args)))) | ||
| 373 | rval))) | ||
| 374 | |||
| 375 | (defun eieio--generic-call-primary-only (method args) | ||
| 376 | "Call METHOD with ARGS for methods with only :PRIMARY implementations. | ||
| 377 | ARGS provides the context on which implementation to use. | ||
| 378 | This should only be called from a generic function. | ||
| 379 | |||
| 380 | This method is like `eieio--generic-call', but only | ||
| 381 | implementations in the :PRIMARY slot are queried. After many | ||
| 382 | years of use, it appears that over 90% of methods in use | ||
| 383 | have :PRIMARY implementations only. We can therefore optimize | ||
| 384 | for this common case to improve performance." | ||
| 385 | ;; We must expand our arguments first as they are always | ||
| 386 | ;; passed in as quoted symbols | ||
| 387 | (let ((newargs nil) (mclass nil) (lambdas nil) | ||
| 388 | (eieio--generic-call-arglst args) | ||
| 389 | (firstarg nil) | ||
| 390 | (primarymethodlist nil) | ||
| 391 | ) | ||
| 392 | ;; get a copy | ||
| 393 | (setq newargs args | ||
| 394 | firstarg (car newargs)) | ||
| 395 | |||
| 396 | ;; Determine the class to use. | ||
| 397 | (cond ((eieio-object-p firstarg) | ||
| 398 | (setq mclass (eieio--object-class-name firstarg))) | ||
| 399 | ((not firstarg) | ||
| 400 | (error "Method %s called on nil" method)) | ||
| 401 | (t | ||
| 402 | (error "Primary-only method %s called on something not an object" method))) | ||
| 403 | ;; Make sure the class is a valid class | ||
| 404 | ;; mclass can be nil (meaning a generic for should be used. | ||
| 405 | ;; mclass cannot have a value that is not a class, however. | ||
| 406 | (when (null mclass) | ||
| 407 | (error "Cannot dispatch method %S on class %S" method mclass) | ||
| 408 | ) | ||
| 409 | |||
| 410 | ;; :primary methods | ||
| 411 | (setq lambdas (eieio--generic-form method eieio--method-primary mclass)) | ||
| 412 | (setq primarymethodlist ;; Re-use even with bad name here | ||
| 413 | (eieio--mt-method-list method eieio--method-primary mclass)) | ||
| 414 | |||
| 415 | ;; Now loop through all occurrences forms which we must execute | ||
| 416 | ;; (which are happily sorted now) and execute them all! | ||
| 417 | (eieio--with-scoped-class (cdr lambdas) | ||
| 418 | (let* ((rval nil) (lastval nil) | ||
| 419 | (eieio--generic-call-key eieio--method-primary) | ||
| 420 | ;; Use the cdr, as the first element is the fcn | ||
| 421 | ;; we are calling right now. | ||
| 422 | (eieio--generic-call-next-method-list (cdr primarymethodlist)) | ||
| 423 | ) | ||
| 424 | |||
| 425 | (if (or (not lambdas) (not (car lambdas))) | ||
| 426 | |||
| 427 | ;; No methods found for this impl... | ||
| 428 | (if (eieio-object-p (car args)) | ||
| 429 | (setq rval (apply #'no-applicable-method | ||
| 430 | (car args) method args)) | ||
| 431 | (signal | ||
| 432 | 'no-method-definition | ||
| 433 | (list method args))) | ||
| 434 | |||
| 435 | ;; Do the regular implementation here. | ||
| 436 | |||
| 437 | (run-hook-with-args 'eieio-pre-method-execution-functions | ||
| 438 | lambdas) | ||
| 439 | |||
| 440 | (setq lastval (apply (car lambdas) newargs)) | ||
| 441 | (setq rval lastval)) | ||
| 442 | |||
| 443 | rval)))) | ||
| 444 | |||
| 445 | (defun eieio--mt-method-list (method key class) | ||
| 446 | "Return an alist list of methods lambdas. | ||
| 447 | METHOD is the method name. | ||
| 448 | KEY represents either :before, or :after methods. | ||
| 449 | CLASS is the starting class to search from in the method tree. | ||
| 450 | If CLASS is nil, then an empty list of methods should be returned." | ||
| 451 | ;; Note: eieiomt - the MT means MethodTree. See more comments below | ||
| 452 | ;; for the rest of the eieiomt methods. | ||
| 453 | |||
| 454 | ;; Collect lambda expressions stored for the class and its parent | ||
| 455 | ;; classes. | ||
| 456 | (let (lambdas) | ||
| 457 | (dolist (ancestor (eieio--class-precedence-list (eieio--class-v class))) | ||
| 458 | ;; Lookup the form to use for the PRIMARY object for the next level | ||
| 459 | (let ((tmpl (eieio--generic-form method key ancestor))) | ||
| 460 | (when (and tmpl | ||
| 461 | (or (not lambdas) | ||
| 462 | ;; This prevents duplicates coming out of the | ||
| 463 | ;; class method optimizer. Perhaps we should | ||
| 464 | ;; just not optimize before/afters? | ||
| 465 | (not (member tmpl lambdas)))) | ||
| 466 | (push tmpl lambdas)))) | ||
| 467 | |||
| 468 | ;; Return collected lambda. For :after methods, return in current | ||
| 469 | ;; order (most general class last); Otherwise, reverse order. | ||
| 470 | (if (eq key eieio--method-after) | ||
| 471 | lambdas | ||
| 472 | (nreverse lambdas)))) | ||
| 473 | |||
| 474 | |||
| 475 | ;;; | ||
| 476 | ;; eieio-method-tree : eieio--mt- | ||
| 477 | ;; | ||
| 478 | ;; Stored as eieio-method-tree in property list of a generic method | ||
| 479 | ;; | ||
| 480 | ;; (eieio-method-tree . [BEFORE PRIMARY AFTER | ||
| 481 | ;; genericBEFORE genericPRIMARY genericAFTER]) | ||
| 482 | ;; and | ||
| 483 | ;; (eieio-method-hashtable . [BEFORE PRIMARY AFTER | ||
| 484 | ;; genericBEFORE genericPRIMARY genericAFTER]) | ||
| 485 | ;; where the association is a vector. | ||
| 486 | ;; (aref 0 -- all static methods. | ||
| 487 | ;; (aref 1 -- all methods classified as :before | ||
| 488 | ;; (aref 2 -- all methods classified as :primary | ||
| 489 | ;; (aref 3 -- all methods classified as :after | ||
| 490 | ;; (aref 4 -- a generic classified as :before | ||
| 491 | ;; (aref 5 -- a generic classified as :primary | ||
| 492 | ;; (aref 6 -- a generic classified as :after | ||
| 493 | ;; | ||
| 494 | (defvar eieio--mt--optimizing-hashtable nil | ||
| 495 | "While mapping atoms, this contain the hashtable being optimized.") | ||
| 496 | |||
| 497 | (defun eieio--mt-install (method-name) | ||
| 498 | "Install the method tree, and hashtable onto METHOD-NAME. | ||
| 499 | Do not do the work if they already exist." | ||
| 500 | (unless (and (get method-name 'eieio-method-tree) | ||
| 501 | (get method-name 'eieio-method-hashtable)) | ||
| 502 | (put method-name 'eieio-method-tree | ||
| 503 | (make-vector eieio--method-num-slots nil)) | ||
| 504 | (let ((emto (put method-name 'eieio-method-hashtable | ||
| 505 | (make-vector eieio--method-num-slots nil)))) | ||
| 506 | (aset emto 0 (make-hash-table :test 'eq)) | ||
| 507 | (aset emto 1 (make-hash-table :test 'eq)) | ||
| 508 | (aset emto 2 (make-hash-table :test 'eq)) | ||
| 509 | (aset emto 3 (make-hash-table :test 'eq))))) | ||
| 510 | |||
| 511 | (defun eieio--mt-add (method-name method key class) | ||
| 512 | "Add to METHOD-NAME the forms METHOD in a call position KEY for CLASS. | ||
| 513 | METHOD-NAME is the name created by a call to `defgeneric'. | ||
| 514 | METHOD are the forms for a given implementation. | ||
| 515 | KEY is an integer (see comment in eieio.el near this function) which | ||
| 516 | is associated with the :static :before :primary and :after tags. | ||
| 517 | It also indicates if CLASS is defined or not. | ||
| 518 | CLASS is the class this method is associated with." | ||
| 519 | (if (or (> key eieio--method-num-slots) (< key 0)) | ||
| 520 | (error "eieio--mt-add: method key error!")) | ||
| 521 | (let ((emtv (get method-name 'eieio-method-tree)) | ||
| 522 | (emto (get method-name 'eieio-method-hashtable))) | ||
| 523 | ;; Make sure the method tables are available. | ||
| 524 | (unless (and emtv emto) | ||
| 525 | (error "Programmer error: eieio--mt-add")) | ||
| 526 | ;; only add new cells on if it doesn't already exist! | ||
| 527 | (if (assq class (aref emtv key)) | ||
| 528 | (setcdr (assq class (aref emtv key)) method) | ||
| 529 | (aset emtv key (cons (cons class method) (aref emtv key)))) | ||
| 530 | ;; Add function definition into newly created symbol, and store | ||
| 531 | ;; said symbol in the correct hashtable, otherwise use the | ||
| 532 | ;; other array to keep this stuff. | ||
| 533 | (if (< key eieio--method-num-lists) | ||
| 534 | (puthash (eieio--class-v class) (list method) (aref emto key))) | ||
| 535 | ;; Save the defmethod file location in a symbol property. | ||
| 536 | (let ((fname (if load-in-progress | ||
| 537 | load-file-name | ||
| 538 | buffer-file-name))) | ||
| 539 | (when fname | ||
| 540 | (when (string-match "\\.elc\\'" fname) | ||
| 541 | (setq fname (substring fname 0 (1- (length fname))))) | ||
| 542 | (cl-pushnew (list class fname) (get method-name 'method-locations) | ||
| 543 | :test 'equal))) | ||
| 544 | ;; Now optimize the entire hashtable. | ||
| 545 | (if (< key eieio--method-num-lists) | ||
| 546 | (let ((eieio--mt--optimizing-hashtable (aref emto key))) | ||
| 547 | ;; @todo - Is this overkill? Should we just clear the symbol? | ||
| 548 | (maphash #'eieio--mt--sym-optimize eieio--mt--optimizing-hashtable))) | ||
| 549 | )) | ||
| 550 | |||
| 551 | (defun eieio--mt-next (class) | ||
| 552 | "Return the next parent class for CLASS. | ||
| 553 | If CLASS is a superclass, return variable `eieio-default-superclass'. | ||
| 554 | If CLASS is variable `eieio-default-superclass' then return nil. | ||
| 555 | This is different from function `class-parent' as class parent returns | ||
| 556 | nil for superclasses. This function performs no type checking!" | ||
| 557 | ;; No type-checking because all calls are made from functions which | ||
| 558 | ;; are safe and do checking for us. | ||
| 559 | (or (eieio--class-parent (eieio--class-v class)) | ||
| 560 | (if (eq class 'eieio-default-superclass) | ||
| 561 | nil | ||
| 562 | '(eieio-default-superclass)))) | ||
| 563 | |||
| 564 | (defun eieio--mt--sym-optimize (class s) | ||
| 565 | "Find the next class above S which has a function body for the optimizer." | ||
| 566 | ;; Set the value to nil in case there is no nearest cell. | ||
| 567 | (setcdr s nil) | ||
| 568 | ;; Find the nearest cell that has a function body. If we find one, | ||
| 569 | ;; we replace the nil from above. | ||
| 570 | (catch 'done | ||
| 571 | (dolist (ancestor | ||
| 572 | (cl-rest (eieio--class-precedence-list class))) | ||
| 573 | (let ((ov (gethash ancestor eieio--mt--optimizing-hashtable))) | ||
| 574 | (when (car ov) | ||
| 575 | (setcdr s ancestor) ;; store ov as our next symbol | ||
| 576 | (throw 'done ancestor)))))) | ||
| 577 | |||
| 578 | (defun eieio--generic-form (method key class) | ||
| 579 | "Return the lambda form belonging to METHOD using KEY based upon CLASS. | ||
| 580 | If CLASS is not a class then use `generic' instead. If class has | ||
| 581 | no form, but has a parent class, then trace to that parent class. | ||
| 582 | The first time a form is requested from a symbol, an optimized path | ||
| 583 | is memorized for faster future use." | ||
| 584 | (if (symbolp class) (setq class (eieio--class-v class))) | ||
| 585 | (let ((emto (aref (get method 'eieio-method-hashtable) | ||
| 586 | (if class key (eieio--specialized-key-to-generic-key key))))) | ||
| 587 | (if (eieio--class-p class) | ||
| 588 | ;; 1) find our symbol | ||
| 589 | (let ((cs (gethash class emto))) | ||
| 590 | (unless cs | ||
| 591 | ;; 2) If there isn't one, then make one. | ||
| 592 | ;; This can be slow since it only occurs once | ||
| 593 | (puthash class (setq cs (list nil)) emto) | ||
| 594 | ;; 2.1) Cache its nearest neighbor with a quick optimize | ||
| 595 | ;; which should only occur once for this call ever | ||
| 596 | (let ((eieio--mt--optimizing-hashtable emto)) | ||
| 597 | (eieio--mt--sym-optimize class cs))) | ||
| 598 | ;; 3) If it's bound return this one. | ||
| 599 | (if (car cs) | ||
| 600 | (cons (car cs) class) | ||
| 601 | ;; 4) If it's not bound then this variable knows something | ||
| 602 | (if (cdr cs) | ||
| 603 | (progn | ||
| 604 | ;; 4.1) This symbol holds the next class in its value | ||
| 605 | (setq class (cdr cs) | ||
| 606 | cs (gethash class emto)) | ||
| 607 | ;; 4.2) The optimizer should always have chosen a | ||
| 608 | ;; function-symbol | ||
| 609 | ;;(if (car cs) | ||
| 610 | (cons (car cs) class) | ||
| 611 | ;;(error "EIEIO optimizer: erratic data loss!")) | ||
| 612 | ) | ||
| 613 | ;; There never will be a funcall... | ||
| 614 | nil))) | ||
| 615 | ;; for a generic call, what is a list, is the function body we want. | ||
| 616 | (let ((emtl (aref (get method 'eieio-method-tree) | ||
| 617 | (if class key (eieio--specialized-key-to-generic-key key))))) | ||
| 618 | (if emtl | ||
| 619 | ;; The car of EMTL is supposed to be a class, which in this | ||
| 620 | ;; case is nil, so skip it. | ||
| 621 | (cons (cdr (car emtl)) nil) | ||
| 622 | nil))))) | ||
| 623 | |||
| 624 | |||
| 625 | (define-error 'no-method-definition "No method definition") | ||
| 626 | (define-error 'no-next-method "No next method") | ||
| 627 | |||
| 628 | ;;; CLOS methods and generics | ||
| 629 | ;; | ||
| 630 | (defmacro defgeneric (method _args &optional doc-string) | ||
| 631 | "Create a generic function METHOD. | ||
| 632 | DOC-STRING is the base documentation for this class. A generic | ||
| 633 | function has no body, as its purpose is to decide which method body | ||
| 634 | is appropriate to use. Uses `defmethod' to create methods, and calls | ||
| 635 | `defgeneric' for you. With this implementation the ARGS are | ||
| 636 | currently ignored. You can use `defgeneric' to apply specialized | ||
| 637 | top level documentation to a method." | ||
| 638 | (declare (doc-string 3)) | ||
| 639 | `(eieio--defalias ',method | ||
| 640 | (eieio--defgeneric-init-form ',method ,doc-string))) | ||
| 641 | |||
| 642 | (defmacro defmethod (method &rest args) | ||
| 643 | "Create a new METHOD through `defgeneric' with ARGS. | ||
| 644 | |||
| 645 | The optional second argument KEY is a specifier that | ||
| 646 | modifies how the method is called, including: | ||
| 647 | :before - Method will be called before the :primary | ||
| 648 | :primary - The default if not specified | ||
| 649 | :after - Method will be called after the :primary | ||
| 650 | :static - First arg could be an object or class | ||
| 651 | The next argument is the ARGLIST. The ARGLIST specifies the arguments | ||
| 652 | to the method as with `defun'. The first argument can have a type | ||
| 653 | specifier, such as: | ||
| 654 | ((VARNAME CLASS) ARG2 ...) | ||
| 655 | where VARNAME is the name of the local variable for the method being | ||
| 656 | created. The CLASS is a class symbol for a class made with `defclass'. | ||
| 657 | A DOCSTRING comes after the ARGLIST, and is optional. | ||
| 658 | All the rest of the args are the BODY of the method. A method will | ||
| 659 | return the value of the last form in the BODY. | ||
| 660 | |||
| 661 | Summary: | ||
| 662 | |||
| 663 | (defmethod mymethod [:before | :primary | :after | :static] | ||
| 664 | ((typearg class-name) arg2 &optional opt &rest rest) | ||
| 665 | \"doc-string\" | ||
| 666 | body)" | ||
| 667 | (declare (doc-string 3) | ||
| 668 | (debug | ||
| 669 | (&define ; this means we are defining something | ||
| 670 | [&or name ("setf" :name setf name)] | ||
| 671 | ;; ^^ This is the methods symbol | ||
| 672 | [ &optional symbolp ] ; this is key :before etc | ||
| 673 | list ; arguments | ||
| 674 | [ &optional stringp ] ; documentation string | ||
| 675 | def-body ; part to be debugged | ||
| 676 | ))) | ||
| 677 | (let* ((key (if (keywordp (car args)) (pop args))) | ||
| 678 | (params (car args)) | ||
| 679 | (arg1 (car params)) | ||
| 680 | (fargs (if (consp arg1) | ||
| 681 | (cons (car arg1) (cdr params)) | ||
| 682 | params)) | ||
| 683 | (class (if (consp arg1) (nth 1 arg1))) | ||
| 684 | (code `(lambda ,fargs ,@(cdr args)))) | ||
| 685 | `(progn | ||
| 686 | ;; Make sure there is a generic and the byte-compiler sees it. | ||
| 687 | (defgeneric ,method ,args | ||
| 688 | ,(or (documentation code) | ||
| 689 | (format "Generically created method `%s'." method))) | ||
| 690 | (eieio--defmethod ',method ',key ',class #',code)))) | ||
| 691 | |||
| 692 | |||
| 693 | |||
| 694 | ;;; | ||
| 695 | ;; Method Calling Functions | ||
| 696 | |||
| 697 | (defun next-method-p () | ||
| 698 | "Return non-nil if there is a next method. | ||
| 699 | Returns a list of lambda expressions which is the `next-method' | ||
| 700 | order." | ||
| 701 | eieio--generic-call-next-method-list) | ||
| 702 | |||
| 703 | (defun call-next-method (&rest replacement-args) | ||
| 704 | "Call the superclass method from a subclass method. | ||
| 705 | The superclass method is specified in the current method list, | ||
| 706 | and is called the next method. | ||
| 707 | |||
| 708 | If REPLACEMENT-ARGS is non-nil, then use them instead of | ||
| 709 | `eieio--generic-call-arglst'. The generic arg list are the | ||
| 710 | arguments passed in at the top level. | ||
| 711 | |||
| 712 | Use `next-method-p' to find out if there is a next method to call." | ||
| 713 | (if (not (eieio--scoped-class)) | ||
| 714 | (error "`call-next-method' not called within a class specific method")) | ||
| 715 | (if (and (/= eieio--generic-call-key eieio--method-primary) | ||
| 716 | (/= eieio--generic-call-key eieio--method-static)) | ||
| 717 | (error "Cannot `call-next-method' except in :primary or :static methods") | ||
| 718 | ) | ||
| 719 | (let ((newargs (or replacement-args eieio--generic-call-arglst)) | ||
| 720 | (next (car eieio--generic-call-next-method-list)) | ||
| 721 | ) | ||
| 722 | (if (not (and next (car next))) | ||
| 723 | (apply #'no-next-method newargs) | ||
| 724 | (let* ((eieio--generic-call-next-method-list | ||
| 725 | (cdr eieio--generic-call-next-method-list)) | ||
| 726 | (eieio--generic-call-arglst newargs) | ||
| 727 | (fcn (car next)) | ||
| 728 | ) | ||
| 729 | (eieio--with-scoped-class (cdr next) | ||
| 730 | (apply fcn newargs)) )))) | ||
| 731 | |||
| 732 | (defgeneric no-applicable-method (object method &rest args) | ||
| 733 | "Called if there are no implementations for OBJECT in METHOD.") | ||
| 734 | |||
| 735 | (defmethod no-applicable-method (object method &rest _args) | ||
| 736 | "Called if there are no implementations for OBJECT in METHOD. | ||
| 737 | OBJECT is the object which has no method implementation. | ||
| 738 | ARGS are the arguments that were passed to METHOD. | ||
| 739 | |||
| 740 | Implement this for a class to block this signal. The return | ||
| 741 | value becomes the return value of the original method call." | ||
| 742 | (signal 'no-method-definition (list method object))) | ||
| 743 | |||
| 744 | (defgeneric no-next-method (object &rest args) | ||
| 745 | "Called from `call-next-method' when no additional methods are available.") | ||
| 746 | |||
| 747 | (defmethod no-next-method (object &rest args) | ||
| 748 | "Called from `call-next-method' when no additional methods are available. | ||
| 749 | OBJECT is othe object being called on `call-next-method'. | ||
| 750 | ARGS are the arguments it is called by. | ||
| 751 | This method signals `no-next-method' by default. Override this | ||
| 752 | method to not throw an error, and its return value becomes the | ||
| 753 | return value of `call-next-method'." | ||
| 754 | (signal 'no-next-method (list object args))) | ||
| 755 | |||
| 756 | (add-hook 'help-fns-describe-function-functions 'eieio--help-generic) | ||
| 757 | (defun eieio--help-generic (generic) | ||
| 758 | "Describe GENERIC if it is a generic function." | ||
| 759 | (when (and (symbolp generic) (generic-p generic)) | ||
| 760 | (save-excursion | ||
| 761 | (goto-char (point-min)) | ||
| 762 | (when (re-search-forward " in `.+'.$" nil t) | ||
| 763 | (replace-match "."))) | ||
| 764 | (save-excursion | ||
| 765 | (insert "\n\nThis is a generic function" | ||
| 766 | (cond | ||
| 767 | ((and (eieio--generic-primary-only-p generic) | ||
| 768 | (eieio--generic-primary-only-one-p generic)) | ||
| 769 | " with only one primary method") | ||
| 770 | ((eieio--generic-primary-only-p generic) | ||
| 771 | " with only primary methods") | ||
| 772 | (t "")) | ||
| 773 | ".\n\n") | ||
| 774 | (insert (propertize "Implementations:\n\n" 'face 'bold)) | ||
| 775 | (let ((i 4) | ||
| 776 | (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] )) | ||
| 777 | ;; Loop over fanciful generics | ||
| 778 | (while (< i 7) | ||
| 779 | (let ((gm (aref (get generic 'eieio-method-tree) i))) | ||
| 780 | (when gm | ||
| 781 | (insert "Generic " | ||
| 782 | (aref prefix (- i 3)) | ||
| 783 | "\n" | ||
| 784 | (or (nth 2 gm) "Undocumented") | ||
| 785 | "\n\n"))) | ||
| 786 | (setq i (1+ i))) | ||
| 787 | (setq i 0) | ||
| 788 | ;; Loop over defined class-specific methods | ||
| 789 | (while (< i 4) | ||
| 790 | (let* ((gm (reverse (aref (get generic 'eieio-method-tree) i))) | ||
| 791 | cname location) | ||
| 792 | (while gm | ||
| 793 | (setq cname (caar gm)) | ||
| 794 | (insert "`") | ||
| 795 | (help-insert-xref-button (symbol-name cname) | ||
| 796 | 'help-variable cname) | ||
| 797 | (insert "' " (aref prefix i) " ") | ||
| 798 | ;; argument list | ||
| 799 | (let* ((func (cdr (car gm))) | ||
| 800 | (arglst (help-function-arglist func))) | ||
| 801 | (prin1 arglst (current-buffer))) | ||
| 802 | (insert "\n" | ||
| 803 | (or (documentation (cdr (car gm))) | ||
| 804 | "Undocumented")) | ||
| 805 | ;; Print file location if available | ||
| 806 | (when (and (setq location (get generic 'method-locations)) | ||
| 807 | (setq location (assoc cname location))) | ||
| 808 | (setq location (cadr location)) | ||
| 809 | (insert "\n\nDefined in `") | ||
| 810 | (help-insert-xref-button | ||
| 811 | (file-name-nondirectory location) | ||
| 812 | 'eieio-method-def cname generic location) | ||
| 813 | (insert "'\n")) | ||
| 814 | (setq gm (cdr gm)) | ||
| 815 | (insert "\n"))) | ||
| 816 | (setq i (1+ i))))))) | ||
| 817 | |||
| 818 | ;;; Obsolete backward compatibility functions. | ||
| 819 | ;; Needed to run byte-code compiled with the EIEIO of Emacs-23. | ||
| 820 | |||
| 821 | (defun eieio-defmethod (method args) | ||
| 822 | "Obsolete work part of an old version of the `defmethod' macro." | ||
| 823 | (let ((key nil) (body nil) (firstarg nil) (argfix nil) (argclass nil) loopa) | ||
| 824 | ;; find optional keys | ||
| 825 | (setq key | ||
| 826 | (cond ((memq (car args) '(:BEFORE :before)) | ||
| 827 | (setq args (cdr args)) | ||
| 828 | eieio--method-before) | ||
| 829 | ((memq (car args) '(:AFTER :after)) | ||
| 830 | (setq args (cdr args)) | ||
| 831 | eieio--method-after) | ||
| 832 | ((memq (car args) '(:STATIC :static)) | ||
| 833 | (setq args (cdr args)) | ||
| 834 | eieio--method-static) | ||
| 835 | ((memq (car args) '(:PRIMARY :primary)) | ||
| 836 | (setq args (cdr args)) | ||
| 837 | eieio--method-primary) | ||
| 838 | ;; Primary key. | ||
| 839 | (t eieio--method-primary))) | ||
| 840 | ;; Get body, and fix contents of args to be the arguments of the fn. | ||
| 841 | (setq body (cdr args) | ||
| 842 | args (car args)) | ||
| 843 | (setq loopa args) | ||
| 844 | ;; Create a fixed version of the arguments. | ||
| 845 | (while loopa | ||
| 846 | (setq argfix (cons (if (listp (car loopa)) (car (car loopa)) (car loopa)) | ||
| 847 | argfix)) | ||
| 848 | (setq loopa (cdr loopa))) | ||
| 849 | ;; Make sure there is a generic. | ||
| 850 | (eieio-defgeneric | ||
| 851 | method | ||
| 852 | (if (stringp (car body)) | ||
| 853 | (car body) (format "Generically created method `%s'." method))) | ||
| 854 | ;; create symbol for property to bind to. If the first arg is of | ||
| 855 | ;; the form (varname vartype) and `vartype' is a class, then | ||
| 856 | ;; that class will be the type symbol. If not, then it will fall | ||
| 857 | ;; under the type `primary' which is a non-specific calling of the | ||
| 858 | ;; function. | ||
| 859 | (setq firstarg (car args)) | ||
| 860 | (if (listp firstarg) | ||
| 861 | (progn | ||
| 862 | (setq argclass (nth 1 firstarg)) | ||
| 863 | (if (not (class-p argclass)) | ||
| 864 | (error "Unknown class type %s in method parameters" | ||
| 865 | (nth 1 firstarg)))) | ||
| 866 | ;; Generics are higher. | ||
| 867 | (setq key (eieio--specialized-key-to-generic-key key))) | ||
| 868 | ;; Put this lambda into the symbol so we can find it. | ||
| 869 | (if (byte-code-function-p (car-safe body)) | ||
| 870 | (eieio--mt-add method (car-safe body) key argclass) | ||
| 871 | (eieio--mt-add method (append (list 'lambda (reverse argfix)) body) | ||
| 872 | key argclass)) | ||
| 873 | ) | ||
| 874 | |||
| 875 | (eieio--method-optimize-primary method) | ||
| 876 | |||
| 877 | method) | ||
| 878 | (make-obsolete 'eieio-defmethod 'eieio--defmethod "24.1") | ||
| 879 | |||
| 880 | (defun eieio-defgeneric (method doc-string) | ||
| 881 | "Obsolete work part of an old version of the `defgeneric' macro." | ||
| 882 | (if (and (fboundp method) (not (generic-p method)) | ||
| 883 | (or (byte-code-function-p (symbol-function method)) | ||
| 884 | (not (eq 'autoload (car (symbol-function method))))) | ||
| 885 | ) | ||
| 886 | (error "You cannot create a generic/method over an existing symbol: %s" | ||
| 887 | method)) | ||
| 888 | ;; Don't do this over and over. | ||
| 889 | (unless (fboundp 'method) | ||
| 890 | ;; This defun tells emacs where the first definition of this | ||
| 891 | ;; method is defined. | ||
| 892 | `(defun ,method nil) | ||
| 893 | ;; Make sure the method tables are installed. | ||
| 894 | (eieio--mt-install method) | ||
| 895 | ;; Apply the actual body of this function. | ||
| 896 | (put method 'function-documentation doc-string) | ||
| 897 | (fset method (eieio--defgeneric-form method)) | ||
| 898 | ;; Return the method | ||
| 899 | 'method)) | ||
| 900 | (make-obsolete 'eieio-defgeneric nil "24.1") | ||
| 901 | |||
| 902 | (provide 'eieio-generic) | ||
| 903 | |||
| 904 | ;;; eieio-generic.el ends here | ||
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index bef7ceb259a..13ad120a9b5 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el | |||
| @@ -60,7 +60,7 @@ Argument PREFIX is the character prefix to use. | |||
| 60 | Argument CH-PREFIX is another character prefix to display." | 60 | Argument CH-PREFIX is another character prefix to display." |
| 61 | (eieio--check-type class-p this-root) | 61 | (eieio--check-type class-p this-root) |
| 62 | (let ((myname (symbol-name this-root)) | 62 | (let ((myname (symbol-name this-root)) |
| 63 | (chl (eieio--class-children (class-v this-root))) | 63 | (chl (eieio--class-children (eieio--class-v this-root))) |
| 64 | (fprefix (concat ch-prefix " +--")) | 64 | (fprefix (concat ch-prefix " +--")) |
| 65 | (mprefix (concat ch-prefix " | ")) | 65 | (mprefix (concat ch-prefix " | ")) |
| 66 | (lprefix (concat ch-prefix " "))) | 66 | (lprefix (concat ch-prefix " "))) |
| @@ -81,7 +81,7 @@ If CLASS is actually an object, then also display current values of that object. | |||
| 81 | ;; Header line | 81 | ;; Header line |
| 82 | (prin1 class) | 82 | (prin1 class) |
| 83 | (insert " is a" | 83 | (insert " is a" |
| 84 | (if (class-option class :abstract) | 84 | (if (eieio--class-option (eieio--class-v class) :abstract) |
| 85 | "n abstract" | 85 | "n abstract" |
| 86 | "") | 86 | "") |
| 87 | " class") | 87 | " class") |
| @@ -149,7 +149,7 @@ If CLASS is actually an object, then also display current values of that object. | |||
| 149 | (defun eieio-help-class-slots (class) | 149 | (defun eieio-help-class-slots (class) |
| 150 | "Print help description for the slots in CLASS. | 150 | "Print help description for the slots in CLASS. |
| 151 | Outputs to the current buffer." | 151 | Outputs to the current buffer." |
| 152 | (let* ((cv (class-v class)) | 152 | (let* ((cv (eieio--class-v class)) |
| 153 | (docs (eieio--class-public-doc cv)) | 153 | (docs (eieio--class-public-doc cv)) |
| 154 | (names (eieio--class-public-a cv)) | 154 | (names (eieio--class-public-a cv)) |
| 155 | (deflt (eieio--class-public-d cv)) | 155 | (deflt (eieio--class-public-d cv)) |
| @@ -218,11 +218,10 @@ Outputs to the current buffer." | |||
| 218 | (defun eieio-build-class-list (class) | 218 | (defun eieio-build-class-list (class) |
| 219 | "Return a list of all classes that inherit from CLASS." | 219 | "Return a list of all classes that inherit from CLASS." |
| 220 | (if (class-p class) | 220 | (if (class-p class) |
| 221 | (apply #'append | 221 | (cl-mapcan |
| 222 | (mapcar | 222 | (lambda (c) |
| 223 | (lambda (c) | 223 | (append (list c) (eieio-build-class-list c))) |
| 224 | (append (list c) (eieio-build-class-list c))) | 224 | (eieio--class-children (eieio--class-v class))) |
| 225 | (eieio-class-children-fast class))) | ||
| 226 | (list class))) | 225 | (list class))) |
| 227 | 226 | ||
| 228 | (defun eieio-build-class-alist (&optional class instantiable-only buildlist) | 227 | (defun eieio-build-class-alist (&optional class instantiable-only buildlist) |
| @@ -231,15 +230,16 @@ Optional argument CLASS is the class to start with. | |||
| 231 | If INSTANTIABLE-ONLY is non nil, only allow names of classes which | 230 | If INSTANTIABLE-ONLY is non nil, only allow names of classes which |
| 232 | are not abstract, otherwise allow all classes. | 231 | are not abstract, otherwise allow all classes. |
| 233 | Optional argument BUILDLIST is more list to attach and is used internally." | 232 | Optional argument BUILDLIST is more list to attach and is used internally." |
| 234 | (let* ((cc (or class eieio-default-superclass)) | 233 | (let* ((cc (or class 'eieio-default-superclass)) |
| 235 | (sublst (eieio--class-children (class-v cc)))) | 234 | (sublst (eieio--class-children (eieio--class-v cc)))) |
| 236 | (unless (assoc (symbol-name cc) buildlist) | 235 | (unless (assoc (symbol-name cc) buildlist) |
| 237 | (when (or (not instantiable-only) (not (class-abstract-p cc))) | 236 | (when (or (not instantiable-only) (not (class-abstract-p cc))) |
| 237 | ;; FIXME: Completion tables don't need alists, and ede/generic.el needs | ||
| 238 | ;; the symbols rather than their names. | ||
| 238 | (setq buildlist (cons (cons (symbol-name cc) 1) buildlist)))) | 239 | (setq buildlist (cons (cons (symbol-name cc) 1) buildlist)))) |
| 239 | (while sublst | 240 | (dolist (elem sublst) |
| 240 | (setq buildlist (eieio-build-class-alist | 241 | (setq buildlist (eieio-build-class-alist |
| 241 | (car sublst) instantiable-only buildlist)) | 242 | elem instantiable-only buildlist))) |
| 242 | (setq sublst (cdr sublst))) | ||
| 243 | buildlist)) | 243 | buildlist)) |
| 244 | 244 | ||
| 245 | (defvar eieio-read-class nil | 245 | (defvar eieio-read-class nil |
| @@ -311,132 +311,59 @@ are not abstract." | |||
| 311 | (eieio-help-class ctr)) | 311 | (eieio-help-class ctr)) |
| 312 | )))) | 312 | )))) |
| 313 | 313 | ||
| 314 | |||
| 315 | ;;;###autoload | ||
| 316 | (defun eieio-help-generic (generic) | ||
| 317 | "Describe GENERIC if it is a generic function." | ||
| 318 | (when (and (symbolp generic) (generic-p generic)) | ||
| 319 | (save-excursion | ||
| 320 | (goto-char (point-min)) | ||
| 321 | (when (re-search-forward " in `.+'.$" nil t) | ||
| 322 | (replace-match "."))) | ||
| 323 | (save-excursion | ||
| 324 | (insert "\n\nThis is a generic function" | ||
| 325 | (cond | ||
| 326 | ((and (generic-primary-only-p generic) | ||
| 327 | (generic-primary-only-one-p generic)) | ||
| 328 | " with only one primary method") | ||
| 329 | ((generic-primary-only-p generic) | ||
| 330 | " with only primary methods") | ||
| 331 | (t "")) | ||
| 332 | ".\n\n") | ||
| 333 | (insert (propertize "Implementations:\n\n" 'face 'bold)) | ||
| 334 | (let ((i 4) | ||
| 335 | (prefix [ ":STATIC" ":BEFORE" ":PRIMARY" ":AFTER" ] )) | ||
| 336 | ;; Loop over fanciful generics | ||
| 337 | (while (< i 7) | ||
| 338 | (let ((gm (aref (get generic 'eieio-method-tree) i))) | ||
| 339 | (when gm | ||
| 340 | (insert "Generic " | ||
| 341 | (aref prefix (- i 3)) | ||
| 342 | "\n" | ||
| 343 | (or (nth 2 gm) "Undocumented") | ||
| 344 | "\n\n"))) | ||
| 345 | (setq i (1+ i))) | ||
| 346 | (setq i 0) | ||
| 347 | ;; Loop over defined class-specific methods | ||
| 348 | (while (< i 4) | ||
| 349 | (let* ((gm (reverse (aref (get generic 'eieio-method-tree) i))) | ||
| 350 | cname location) | ||
| 351 | (while gm | ||
| 352 | (setq cname (caar gm)) | ||
| 353 | (insert "`") | ||
| 354 | (help-insert-xref-button (symbol-name cname) | ||
| 355 | 'help-variable cname) | ||
| 356 | (insert "' " (aref prefix i) " ") | ||
| 357 | ;; argument list | ||
| 358 | (let* ((func (cdr (car gm))) | ||
| 359 | (arglst (help-function-arglist func))) | ||
| 360 | (prin1 arglst (current-buffer))) | ||
| 361 | (insert "\n" | ||
| 362 | (or (documentation (cdr (car gm))) | ||
| 363 | "Undocumented")) | ||
| 364 | ;; Print file location if available | ||
| 365 | (when (and (setq location (get generic 'method-locations)) | ||
| 366 | (setq location (assoc cname location))) | ||
| 367 | (setq location (cadr location)) | ||
| 368 | (insert "\n\nDefined in `") | ||
| 369 | (help-insert-xref-button | ||
| 370 | (file-name-nondirectory location) | ||
| 371 | 'eieio-method-def cname generic location) | ||
| 372 | (insert "'\n")) | ||
| 373 | (setq gm (cdr gm)) | ||
| 374 | (insert "\n"))) | ||
| 375 | (setq i (1+ i))))))) | ||
| 376 | |||
| 377 | (defun eieio-all-generic-functions (&optional class) | 314 | (defun eieio-all-generic-functions (&optional class) |
| 378 | "Return a list of all generic functions. | 315 | "Return a list of all generic functions. |
| 379 | Optional CLASS argument returns only those functions that contain | 316 | Optional CLASS argument returns only those functions that contain |
| 380 | methods for CLASS." | 317 | methods for CLASS." |
| 381 | (let ((l nil) tree (cn (if class (symbol-name class) nil))) | 318 | (let ((l nil)) |
| 382 | (mapatoms | 319 | (mapatoms |
| 383 | (lambda (symbol) | 320 | (lambda (symbol) |
| 384 | (setq tree (get symbol 'eieio-method-obarray)) | 321 | (let ((tree (get symbol 'eieio-method-hashtable))) |
| 385 | (if tree | 322 | (when tree |
| 386 | (progn | 323 | ;; A symbol might be interned for that class in one of |
| 387 | ;; A symbol might be interned for that class in one of | 324 | ;; these three slots in the method-obarray. |
| 388 | ;; these three slots in the method-obarray. | 325 | (if (or (not class) |
| 389 | (if (or (not class) | 326 | (car (gethash class (aref tree 0))) |
| 390 | (fboundp (intern-soft cn (aref tree 0))) | 327 | (car (gethash class (aref tree 1))) |
| 391 | (fboundp (intern-soft cn (aref tree 1))) | 328 | (car (gethash class (aref tree 2)))) |
| 392 | (fboundp (intern-soft cn (aref tree 2)))) | 329 | (setq l (cons symbol l))))))) |
| 393 | (setq l (cons symbol l))))))) | ||
| 394 | l)) | 330 | l)) |
| 395 | 331 | ||
| 396 | (defun eieio-method-documentation (generic class) | 332 | (defun eieio-method-documentation (generic class) |
| 397 | "Return a list of the specific documentation of GENERIC for CLASS. | 333 | "Return a list of the specific documentation of GENERIC for CLASS. |
| 398 | If there is not an explicit method for CLASS in GENERIC, or if that | 334 | If there is not an explicit method for CLASS in GENERIC, or if that |
| 399 | function has no documentation, then return nil." | 335 | function has no documentation, then return nil." |
| 400 | (let ((tree (get generic 'eieio-method-obarray)) | 336 | (let ((tree (get generic 'eieio-method-hashtable))) |
| 401 | (cn (symbol-name class)) | 337 | (when tree |
| 402 | before primary after) | ||
| 403 | (if (not tree) | ||
| 404 | nil | ||
| 405 | ;; A symbol might be interned for that class in one of | 338 | ;; A symbol might be interned for that class in one of |
| 406 | ;; these three slots in the method-obarray. | 339 | ;; these three slots in the method-hashtable. |
| 407 | (setq before (intern-soft cn (aref tree 0)) | 340 | ;; FIXME: Where do these 0/1/2 come from? Isn't 0 for :static, |
| 408 | primary (intern-soft cn (aref tree 1)) | 341 | ;; 1 for before, and 2 for primary (and 3 for after)? |
| 409 | after (intern-soft cn (aref tree 2))) | 342 | (let ((before (car (gethash class (aref tree 0)))) |
| 410 | (if (not (or (fboundp before) | 343 | (primary (car (gethash class (aref tree 1)))) |
| 411 | (fboundp primary) | 344 | (after (car (gethash class (aref tree 2))))) |
| 412 | (fboundp after))) | 345 | (if (not (or before primary after)) |
| 413 | nil | 346 | nil |
| 414 | (list (if (fboundp before) | 347 | (list (if before |
| 415 | (cons (help-function-arglist before) | 348 | (cons (help-function-arglist before) |
| 416 | (documentation before)) | 349 | (documentation before)) |
| 417 | nil) | 350 | nil) |
| 418 | (if (fboundp primary) | 351 | (if primary |
| 419 | (cons (help-function-arglist primary) | 352 | (cons (help-function-arglist primary) |
| 420 | (documentation primary)) | 353 | (documentation primary)) |
| 421 | nil) | 354 | nil) |
| 422 | (if (fboundp after) | 355 | (if after |
| 423 | (cons (help-function-arglist after) | 356 | (cons (help-function-arglist after) |
| 424 | (documentation after)) | 357 | (documentation after)) |
| 425 | nil)))))) | 358 | nil))))))) |
| 426 | 359 | ||
| 427 | (defvar eieio-read-generic nil | 360 | (defvar eieio-read-generic nil |
| 428 | "History of the `eieio-read-generic' prompt.") | 361 | "History of the `eieio-read-generic' prompt.") |
| 429 | 362 | ||
| 430 | (defun eieio-read-generic-p (fn) | ||
| 431 | "Function used in function `eieio-read-generic'. | ||
| 432 | This is because `generic-p' is a macro. | ||
| 433 | Argument FN is the function to test." | ||
| 434 | (generic-p fn)) | ||
| 435 | |||
| 436 | (defun eieio-read-generic (prompt &optional historyvar) | 363 | (defun eieio-read-generic (prompt &optional historyvar) |
| 437 | "Read a generic function from the minibuffer with PROMPT. | 364 | "Read a generic function from the minibuffer with PROMPT. |
| 438 | Optional argument HISTORYVAR is the variable to use as history." | 365 | Optional argument HISTORYVAR is the variable to use as history." |
| 439 | (intern (completing-read prompt obarray 'eieio-read-generic-p | 366 | (intern (completing-read prompt obarray #'generic-p |
| 440 | t nil (or historyvar 'eieio-read-generic)))) | 367 | t nil (or historyvar 'eieio-read-generic)))) |
| 441 | 368 | ||
| 442 | ;;; METHOD STATS | 369 | ;;; METHOD STATS |
| @@ -627,21 +554,21 @@ Optional argument HISTORYVAR is the variable to use as history." | |||
| 627 | () | 554 | () |
| 628 | "Menu part in easymenu format used in speedbar while in `eieio' mode.") | 555 | "Menu part in easymenu format used in speedbar while in `eieio' mode.") |
| 629 | 556 | ||
| 630 | (defun eieio-class-speedbar (dir-or-object depth) | 557 | (defun eieio-class-speedbar (_dir-or-object _depth) |
| 631 | "Create buttons in speedbar that represents the current project. | 558 | "Create buttons in speedbar that represents the current project. |
| 632 | DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the | 559 | DIR-OR-OBJECT is the object to expand, or nil, and DEPTH is the |
| 633 | current expansion depth." | 560 | current expansion depth." |
| 634 | (when (eq (point-min) (point-max)) | 561 | (when (eq (point-min) (point-max)) |
| 635 | ;; This function is only called once, to start the whole deal. | 562 | ;; This function is only called once, to start the whole deal. |
| 636 | ;; Create and expand the default object. | 563 | ;; Create and expand the default object. |
| 637 | (eieio-class-button eieio-default-superclass 0) | 564 | (eieio-class-button 'eieio-default-superclass 0) |
| 638 | (forward-line -1) | 565 | (forward-line -1) |
| 639 | (speedbar-expand-line))) | 566 | (speedbar-expand-line))) |
| 640 | 567 | ||
| 641 | (defun eieio-class-button (class depth) | 568 | (defun eieio-class-button (class depth) |
| 642 | "Draw a speedbar button at the current point for CLASS at DEPTH." | 569 | "Draw a speedbar button at the current point for CLASS at DEPTH." |
| 643 | (eieio--check-type class-p class) | 570 | (eieio--check-type class-p class) |
| 644 | (let ((subclasses (eieio--class-children (class-v class)))) | 571 | (let ((subclasses (eieio--class-children (eieio--class-v class)))) |
| 645 | (if subclasses | 572 | (if subclasses |
| 646 | (speedbar-make-tag-line 'angle ?+ | 573 | (speedbar-make-tag-line 'angle ?+ |
| 647 | 'eieio-sb-expand | 574 | 'eieio-sb-expand |
| @@ -666,7 +593,7 @@ Argument INDENT is the depth of indentation." | |||
| 666 | (speedbar-with-writable | 593 | (speedbar-with-writable |
| 667 | (save-excursion | 594 | (save-excursion |
| 668 | (end-of-line) (forward-char 1) | 595 | (end-of-line) (forward-char 1) |
| 669 | (let ((subclasses (eieio--class-children (class-v class)))) | 596 | (let ((subclasses (eieio--class-children (eieio--class-v class)))) |
| 670 | (while subclasses | 597 | (while subclasses |
| 671 | (eieio-class-button (car subclasses) (1+ indent)) | 598 | (eieio-class-button (car subclasses) (1+ indent)) |
| 672 | (setq subclasses (cdr subclasses))))))) | 599 | (setq subclasses (cdr subclasses))))))) |
| @@ -676,7 +603,7 @@ Argument INDENT is the depth of indentation." | |||
| 676 | (t (error "Ooops... not sure what to do"))) | 603 | (t (error "Ooops... not sure what to do"))) |
| 677 | (speedbar-center-buffer-smartly)) | 604 | (speedbar-center-buffer-smartly)) |
| 678 | 605 | ||
| 679 | (defun eieio-describe-class-sb (text token indent) | 606 | (defun eieio-describe-class-sb (_text token _indent) |
| 680 | "Describe the class TEXT in TOKEN. | 607 | "Describe the class TEXT in TOKEN. |
| 681 | INDENT is the current indentation level." | 608 | INDENT is the current indentation level." |
| 682 | (dframe-with-attached-buffer | 609 | (dframe-with-attached-buffer |
diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el index cf676256d43..b236f0f03e1 100644 --- a/lisp/emacs-lisp/eieio-speedbar.el +++ b/lisp/emacs-lisp/eieio-speedbar.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; eieio-speedbar.el -- Classes for managing speedbar displays. | 1 | ;;; eieio-speedbar.el -- Classes for managing speedbar displays. -*- lexical-binding:t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1999-2002, 2005, 2007-2015 Free Software Foundation, | 3 | ;; Copyright (C) 1999-2002, 2005, 2007-2015 Free Software Foundation, |
| 4 | ;; Inc. | 4 | ;; Inc. |
| @@ -200,7 +200,7 @@ that path." | |||
| 200 | "Return a string describing OBJECT." | 200 | "Return a string describing OBJECT." |
| 201 | (eieio-object-name-string object)) | 201 | (eieio-object-name-string object)) |
| 202 | 202 | ||
| 203 | (defmethod eieio-speedbar-derive-line-path (object) | 203 | (defmethod eieio-speedbar-derive-line-path (_object) |
| 204 | "Return the path which OBJECT has something to do with." | 204 | "Return the path which OBJECT has something to do with." |
| 205 | nil) | 205 | nil) |
| 206 | 206 | ||
| @@ -321,7 +321,7 @@ Argument DEPTH is the depth at which the tag line is inserted." | |||
| 321 | (if exp | 321 | (if exp |
| 322 | (eieio-speedbar-expand object (1+ depth)))))) | 322 | (eieio-speedbar-expand object (1+ depth)))))) |
| 323 | 323 | ||
| 324 | (defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) depth) | 324 | (defmethod eieio-speedbar-child-make-tag-lines ((object eieio-speedbar) _depth) |
| 325 | "Base method for creating tag lines for non-object children." | 325 | "Base method for creating tag lines for non-object children." |
| 326 | (error "You must implement `eieio-speedbar-child-make-tag-lines' for %s" | 326 | (error "You must implement `eieio-speedbar-child-make-tag-lines' for %s" |
| 327 | (eieio-object-name object))) | 327 | (eieio-object-name object))) |
| @@ -340,7 +340,7 @@ OBJECT." | |||
| 340 | 340 | ||
| 341 | ;;; Speedbar specific function callbacks. | 341 | ;;; Speedbar specific function callbacks. |
| 342 | ;; | 342 | ;; |
| 343 | (defun eieio-speedbar-object-click (text token indent) | 343 | (defun eieio-speedbar-object-click (_text token _indent) |
| 344 | "Handle a user click on TEXT representing object TOKEN. | 344 | "Handle a user click on TEXT representing object TOKEN. |
| 345 | The object is at indentation level INDENT." | 345 | The object is at indentation level INDENT." |
| 346 | (eieio-speedbar-handle-click token)) | 346 | (eieio-speedbar-handle-click token)) |
| @@ -412,7 +412,7 @@ Optional DEPTH is the depth we start at." | |||
| 412 | 412 | ||
| 413 | ;;; Methods to the eieio-speedbar-* classes which need to be overridden. | 413 | ;;; Methods to the eieio-speedbar-* classes which need to be overridden. |
| 414 | ;; | 414 | ;; |
| 415 | (defmethod eieio-speedbar-object-children ((object eieio-speedbar)) | 415 | (defmethod eieio-speedbar-object-children ((_object eieio-speedbar)) |
| 416 | "Return a list of children to be displayed in speedbar. | 416 | "Return a list of children to be displayed in speedbar. |
| 417 | If the return value is a list of OBJECTs, then those objects are | 417 | If the return value is a list of OBJECTs, then those objects are |
| 418 | queried for details. If the return list is made of strings, | 418 | queried for details. If the return list is made of strings, |
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 361005414de..419a78be469 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el | |||
| @@ -53,17 +53,16 @@ | |||
| 53 | (message eieio-version)) | 53 | (message eieio-version)) |
| 54 | 54 | ||
| 55 | (require 'eieio-core) | 55 | (require 'eieio-core) |
| 56 | (require 'eieio-generic) | ||
| 56 | 57 | ||
| 57 | 58 | ||
| 58 | ;;; Defining a new class | 59 | ;;; Defining a new class |
| 59 | ;; | 60 | ;; |
| 60 | (defmacro defclass (name superclass slots &rest options-and-doc) | 61 | (defmacro defclass (name superclasses slots &rest options-and-doc) |
| 61 | "Define NAME as a new class derived from SUPERCLASS with SLOTS. | 62 | "Define NAME as a new class derived from SUPERCLASS with SLOTS. |
| 62 | OPTIONS-AND-DOC is used as the class' options and base documentation. | 63 | OPTIONS-AND-DOC is used as the class' options and base documentation. |
| 63 | SUPERCLASS is a list of superclasses to inherit from, with SLOTS | 64 | SUPERCLASSES is a list of superclasses to inherit from, with SLOTS |
| 64 | being the slots residing in that class definition. NOTE: Currently | 65 | being the slots residing in that class definition. Supported tags are: |
| 65 | only one slot may exist in SUPERCLASS as multiple inheritance is not | ||
| 66 | yet supported. Supported tags are: | ||
| 67 | 66 | ||
| 68 | :initform - Initializing form. | 67 | :initform - Initializing form. |
| 69 | :initarg - Tag used during initialization. | 68 | :initarg - Tag used during initialization. |
| @@ -114,12 +113,178 @@ Options in CLOS not supported in EIEIO: | |||
| 114 | Due to the way class options are set up, you can add any tags you wish, | 113 | Due to the way class options are set up, you can add any tags you wish, |
| 115 | and reference them using the function `class-option'." | 114 | and reference them using the function `class-option'." |
| 116 | (declare (doc-string 4)) | 115 | (declare (doc-string 4)) |
| 117 | ;; This is eval-and-compile only to silence spurious compiler warnings | 116 | (eieio--check-type listp superclasses) |
| 118 | ;; about functions and variables not known to be defined. | 117 | |
| 119 | ;; When eieio-defclass code is merged here and this becomes | 118 | (cond ((and (stringp (car options-and-doc)) |
| 120 | ;; transparent to the compiler, the eval-and-compile can be removed. | 119 | (/= 1 (% (length options-and-doc) 2))) |
| 121 | `(eval-and-compile | 120 | (error "Too many arguments to `defclass'")) |
| 122 | (eieio-defclass ',name ',superclass ',slots ',options-and-doc))) | 121 | ((and (symbolp (car options-and-doc)) |
| 122 | (/= 0 (% (length options-and-doc) 2))) | ||
| 123 | (error "Too many arguments to `defclass'"))) | ||
| 124 | |||
| 125 | (if (stringp (car options-and-doc)) | ||
| 126 | (setq options-and-doc | ||
| 127 | (cons :documentation options-and-doc))) | ||
| 128 | |||
| 129 | ;; Make sure the method invocation order is a valid value. | ||
| 130 | (let ((io (eieio--class-option-assoc options-and-doc | ||
| 131 | :method-invocation-order))) | ||
| 132 | (when (and io (not (member io '(:depth-first :breadth-first :c3)))) | ||
| 133 | (error "Method invocation order %s is not allowed" io))) | ||
| 134 | |||
| 135 | (let ((testsym1 (intern (concat (symbol-name name) "-p"))) | ||
| 136 | (testsym2 (intern (format "eieio--childp--%s" name))) | ||
| 137 | (accessors ())) | ||
| 138 | |||
| 139 | ;; Collect the accessors we need to define. | ||
| 140 | (pcase-dolist (`(,sname . ,soptions) slots) | ||
| 141 | (let* ((acces (plist-get soptions :accessor)) | ||
| 142 | (initarg (plist-get soptions :initarg)) | ||
| 143 | (reader (plist-get soptions :reader)) | ||
| 144 | (writer (plist-get soptions :writer)) | ||
| 145 | (alloc (plist-get soptions :allocation)) | ||
| 146 | (label (plist-get soptions :label))) | ||
| 147 | |||
| 148 | (if eieio-error-unsupported-class-tags | ||
| 149 | (let ((tmp soptions)) | ||
| 150 | (while tmp | ||
| 151 | (if (not (member (car tmp) '(:accessor | ||
| 152 | :initform | ||
| 153 | :initarg | ||
| 154 | :documentation | ||
| 155 | :protection | ||
| 156 | :reader | ||
| 157 | :writer | ||
| 158 | :allocation | ||
| 159 | :type | ||
| 160 | :custom | ||
| 161 | :label | ||
| 162 | :group | ||
| 163 | :printer | ||
| 164 | :allow-nil-initform | ||
| 165 | :custom-groups))) | ||
| 166 | (signal 'invalid-slot-type (list (car tmp)))) | ||
| 167 | (setq tmp (cdr (cdr tmp)))))) | ||
| 168 | |||
| 169 | ;; Make sure the :allocation parameter has a valid value. | ||
| 170 | (if (not (memq alloc '(nil :class :instance))) | ||
| 171 | (signal 'invalid-slot-type (list :allocation alloc))) | ||
| 172 | |||
| 173 | ;; Label is nil, or a string | ||
| 174 | (if (not (or (null label) (stringp label))) | ||
| 175 | (signal 'invalid-slot-type (list :label label))) | ||
| 176 | |||
| 177 | ;; Is there an initarg, but allocation of class? | ||
| 178 | (if (and initarg (eq alloc :class)) | ||
| 179 | (message "Class allocated slots do not need :initarg")) | ||
| 180 | |||
| 181 | ;; Anyone can have an accessor function. This creates a function | ||
| 182 | ;; of the specified name, and also performs a `defsetf' if applicable | ||
| 183 | ;; so that users can `setf' the space returned by this function. | ||
| 184 | (when acces | ||
| 185 | ;; FIXME: The defmethod below only defines a part of the generic | ||
| 186 | ;; function (good), but the define-setter below affects the whole | ||
| 187 | ;; generic function (bad)! | ||
| 188 | (push `(gv-define-setter ,acces (store object) | ||
| 189 | ;; Apparently, eieio-oset-default doesn't work like | ||
| 190 | ;; oref-default and only accept class arguments! | ||
| 191 | (list ',(if nil ;; (eq alloc :class) | ||
| 192 | 'eieio-oset-default | ||
| 193 | 'eieio-oset) | ||
| 194 | object '',sname store)) | ||
| 195 | accessors) | ||
| 196 | (push `(defmethod ,acces ,(if (eq alloc :class) :static :primary) | ||
| 197 | ((this ,name)) | ||
| 198 | ,(format | ||
| 199 | "Retrieve the slot `%S' from an object of class `%S'." | ||
| 200 | sname name) | ||
| 201 | (if (slot-boundp this ',sname) | ||
| 202 | ;; Use oref-default for :class allocated slots, since | ||
| 203 | ;; these also accept the use of a class argument instead | ||
| 204 | ;; of an object argument. | ||
| 205 | (,(if (eq alloc :class) 'eieio-oref-default 'eieio-oref) | ||
| 206 | this ',sname) | ||
| 207 | ;; Else - Some error? nil? | ||
| 208 | nil)) | ||
| 209 | accessors)) | ||
| 210 | |||
| 211 | ;; If a writer is defined, then create a generic method of that | ||
| 212 | ;; name whose purpose is to set the value of the slot. | ||
| 213 | (if writer | ||
| 214 | (push `(defmethod ,writer ((this ,name) value) | ||
| 215 | ,(format "Set the slot `%S' of an object of class `%S'." | ||
| 216 | sname name) | ||
| 217 | (setf (slot-value this ',sname) value)) | ||
| 218 | accessors)) | ||
| 219 | ;; If a reader is defined, then create a generic method | ||
| 220 | ;; of that name whose purpose is to access this slot value. | ||
| 221 | (if reader | ||
| 222 | (push `(defmethod ,reader ((this ,name)) | ||
| 223 | ,(format "Access the slot `%S' from object of class `%S'." | ||
| 224 | sname name) | ||
| 225 | (slot-value this ',sname)) | ||
| 226 | accessors)) | ||
| 227 | )) | ||
| 228 | |||
| 229 | `(progn | ||
| 230 | ;; This test must be created right away so we can have self- | ||
| 231 | ;; referencing classes. ei, a class whose slot can contain only | ||
| 232 | ;; pointers to itself. | ||
| 233 | |||
| 234 | ;; Create the test function. | ||
| 235 | (defun ,testsym1 (obj) | ||
| 236 | ,(format "Test OBJ to see if it an object of type %S." name) | ||
| 237 | (and (eieio-object-p obj) | ||
| 238 | (same-class-p obj ',name))) | ||
| 239 | |||
| 240 | (defun ,testsym2 (obj) | ||
| 241 | ,(format | ||
| 242 | "Test OBJ to see if it an object is a child of type %S." | ||
| 243 | name) | ||
| 244 | (and (eieio-object-p obj) | ||
| 245 | (object-of-class-p obj ',name))) | ||
| 246 | |||
| 247 | ,@(when eieio-backward-compatibility | ||
| 248 | (let ((f (intern (format "%s-child-p" name)))) | ||
| 249 | `((defalias ',f ',testsym2) | ||
| 250 | (make-obsolete | ||
| 251 | ',f ,(format "use (cl-typep ... '%s) instead" name) "25.1")))) | ||
| 252 | |||
| 253 | ;; When using typep, (typep OBJ 'myclass) returns t for objects which | ||
| 254 | ;; are subclasses of myclass. For our predicates, however, it is | ||
| 255 | ;; important for EIEIO to be backwards compatible, where | ||
| 256 | ;; myobject-p, and myobject-child-p are different. | ||
| 257 | ;; "cl" uses this technique to specify symbols with specific typep | ||
| 258 | ;; test, so we can let typep have the CLOS documented behavior | ||
| 259 | ;; while keeping our above predicate clean. | ||
| 260 | |||
| 261 | (put ',name 'cl-deftype-satisfies #',testsym2) | ||
| 262 | |||
| 263 | (eieio-defclass-internal ',name ',superclasses ',slots ',options-and-doc) | ||
| 264 | |||
| 265 | ,@accessors | ||
| 266 | |||
| 267 | ;; Create the constructor function | ||
| 268 | ,(if (eieio--class-option-assoc options-and-doc :abstract) | ||
| 269 | ;; Abstract classes cannot be instantiated. Say so. | ||
| 270 | (let ((abs (eieio--class-option-assoc options-and-doc :abstract))) | ||
| 271 | (if (not (stringp abs)) | ||
| 272 | (setq abs (format "Class %s is abstract" name))) | ||
| 273 | `(defun ,name (&rest _) | ||
| 274 | ,(format "You cannot create a new object of type %S." name) | ||
| 275 | (error ,abs))) | ||
| 276 | |||
| 277 | ;; Non-abstract classes need a constructor. | ||
| 278 | `(defun ,name (&rest slots) | ||
| 279 | ,(format "Create a new object with name NAME of class type %S." | ||
| 280 | name) | ||
| 281 | (if (and slots | ||
| 282 | (let ((x (car slots))) | ||
| 283 | (or (stringp x) (null x)))) | ||
| 284 | (funcall (if eieio-backward-compatibility #'ignore #'message) | ||
| 285 | "Obsolete name %S passed to %S constructor" | ||
| 286 | (pop slots) ',name)) | ||
| 287 | (apply #'eieio-constructor ',name slots)))))) | ||
| 123 | 288 | ||
| 124 | 289 | ||
| 125 | ;;; CLOS style implementation of object creators. | 290 | ;;; CLOS style implementation of object creators. |
| @@ -144,75 +309,16 @@ In EIEIO, the class' constructor requires a name for use when printing. | |||
| 144 | `make-instance' in CLOS doesn't use names the way Emacs does, so the | 309 | `make-instance' in CLOS doesn't use names the way Emacs does, so the |
| 145 | class is used as the name slot instead when INITARGS doesn't start with | 310 | class is used as the name slot instead when INITARGS doesn't start with |
| 146 | a string." | 311 | a string." |
| 147 | (if (and (car initargs) (stringp (car initargs))) | 312 | (apply (class-constructor class) initargs)) |
| 148 | (apply (class-constructor class) initargs) | ||
| 149 | (apply (class-constructor class) | ||
| 150 | (cond ((symbolp class) (symbol-name class)) | ||
| 151 | (t (format "%S" class))) | ||
| 152 | initargs))) | ||
| 153 | 313 | ||
| 154 | 314 | ||
| 155 | ;;; CLOS methods and generics | ||
| 156 | ;; | ||
| 157 | (defmacro defgeneric (method _args &optional doc-string) | ||
| 158 | "Create a generic function METHOD. | ||
| 159 | DOC-STRING is the base documentation for this class. A generic | ||
| 160 | function has no body, as its purpose is to decide which method body | ||
| 161 | is appropriate to use. Uses `defmethod' to create methods, and calls | ||
| 162 | `defgeneric' for you. With this implementation the ARGS are | ||
| 163 | currently ignored. You can use `defgeneric' to apply specialized | ||
| 164 | top level documentation to a method." | ||
| 165 | (declare (doc-string 3)) | ||
| 166 | `(eieio--defalias ',method | ||
| 167 | (eieio--defgeneric-init-form ',method ,doc-string))) | ||
| 168 | |||
| 169 | (defmacro defmethod (method &rest args) | ||
| 170 | "Create a new METHOD through `defgeneric' with ARGS. | ||
| 171 | |||
| 172 | The optional second argument KEY is a specifier that | ||
| 173 | modifies how the method is called, including: | ||
| 174 | :before - Method will be called before the :primary | ||
| 175 | :primary - The default if not specified | ||
| 176 | :after - Method will be called after the :primary | ||
| 177 | :static - First arg could be an object or class | ||
| 178 | The next argument is the ARGLIST. The ARGLIST specifies the arguments | ||
| 179 | to the method as with `defun'. The first argument can have a type | ||
| 180 | specifier, such as: | ||
| 181 | ((VARNAME CLASS) ARG2 ...) | ||
| 182 | where VARNAME is the name of the local variable for the method being | ||
| 183 | created. The CLASS is a class symbol for a class made with `defclass'. | ||
| 184 | A DOCSTRING comes after the ARGLIST, and is optional. | ||
| 185 | All the rest of the args are the BODY of the method. A method will | ||
| 186 | return the value of the last form in the BODY. | ||
| 187 | |||
| 188 | Summary: | ||
| 189 | |||
| 190 | (defmethod mymethod [:before | :primary | :after | :static] | ||
| 191 | ((typearg class-name) arg2 &optional opt &rest rest) | ||
| 192 | \"doc-string\" | ||
| 193 | body)" | ||
| 194 | (declare (doc-string 3)) | ||
| 195 | (let* ((key (if (keywordp (car args)) (pop args))) | ||
| 196 | (params (car args)) | ||
| 197 | (arg1 (car params)) | ||
| 198 | (fargs (if (consp arg1) | ||
| 199 | (cons (car arg1) (cdr params)) | ||
| 200 | params)) | ||
| 201 | (class (if (consp arg1) (nth 1 arg1))) | ||
| 202 | (code `(lambda ,fargs ,@(cdr args)))) | ||
| 203 | `(progn | ||
| 204 | ;; Make sure there is a generic and the byte-compiler sees it. | ||
| 205 | (defgeneric ,method ,args | ||
| 206 | ,(or (documentation code) | ||
| 207 | (format "Generically created method `%s'." method))) | ||
| 208 | (eieio--defmethod ',method ',key ',class #',code)))) | ||
| 209 | |||
| 210 | ;;; Get/Set slots in an object. | 315 | ;;; Get/Set slots in an object. |
| 211 | ;; | 316 | ;; |
| 212 | (defmacro oref (obj slot) | 317 | (defmacro oref (obj slot) |
| 213 | "Retrieve the value stored in OBJ in the slot named by SLOT. | 318 | "Retrieve the value stored in OBJ in the slot named by SLOT. |
| 214 | Slot is the name of the slot when created by `defclass' or the label | 319 | Slot is the name of the slot when created by `defclass' or the label |
| 215 | created by the :initarg tag." | 320 | created by the :initarg tag." |
| 321 | (declare (debug (form symbolp))) | ||
| 216 | `(eieio-oref ,obj (quote ,slot))) | 322 | `(eieio-oref ,obj (quote ,slot))) |
| 217 | 323 | ||
| 218 | (defalias 'slot-value 'eieio-oref) | 324 | (defalias 'slot-value 'eieio-oref) |
| @@ -223,6 +329,7 @@ created by the :initarg tag." | |||
| 223 | The default value is the value installed in a class with the :initform | 329 | The default value is the value installed in a class with the :initform |
| 224 | tag. SLOT can be the slot name, or the tag specified by the :initarg | 330 | tag. SLOT can be the slot name, or the tag specified by the :initarg |
| 225 | tag in the `defclass' call." | 331 | tag in the `defclass' call." |
| 332 | (declare (debug (form symbolp))) | ||
| 226 | `(eieio-oref-default ,obj (quote ,slot))) | 333 | `(eieio-oref-default ,obj (quote ,slot))) |
| 227 | 334 | ||
| 228 | ;;; Handy CLOS macros | 335 | ;;; Handy CLOS macros |
| @@ -246,7 +353,7 @@ SPEC-LIST is of a form similar to `let'. For example: | |||
| 246 | Where each VAR is the local variable given to the associated | 353 | Where each VAR is the local variable given to the associated |
| 247 | SLOT. A slot specified without a variable name is given a | 354 | SLOT. A slot specified without a variable name is given a |
| 248 | variable name of the same name as the slot." | 355 | variable name of the same name as the slot." |
| 249 | (declare (indent 2)) | 356 | (declare (indent 2) (debug (sexp sexp def-body))) |
| 250 | (require 'cl-lib) | 357 | (require 'cl-lib) |
| 251 | ;; Transform the spec-list into a cl-symbol-macrolet spec-list. | 358 | ;; Transform the spec-list into a cl-symbol-macrolet spec-list. |
| 252 | (let ((mappings (mapcar (lambda (entry) | 359 | (let ((mappings (mapcar (lambda (entry) |
| @@ -261,33 +368,43 @@ variable name of the same name as the slot." | |||
| 261 | ;; well embedded into an object. | 368 | ;; well embedded into an object. |
| 262 | ;; | 369 | ;; |
| 263 | (define-obsolete-function-alias | 370 | (define-obsolete-function-alias |
| 264 | 'object-class-fast #'eieio--object-class "24.4") | 371 | 'object-class-fast #'eieio--object-class-name "24.4") |
| 265 | 372 | ||
| 266 | (defun eieio-object-name (obj &optional extra) | 373 | (defun eieio-object-name (obj &optional extra) |
| 267 | "Return a Lisp like symbol string for object OBJ. | 374 | "Return a Lisp like symbol string for object OBJ. |
| 268 | If EXTRA, include that in the string returned to represent the symbol." | 375 | If EXTRA, include that in the string returned to represent the symbol." |
| 269 | (eieio--check-type eieio-object-p obj) | 376 | (eieio--check-type eieio-object-p obj) |
| 270 | (format "#<%s %s%s>" (symbol-name (eieio--object-class obj)) | 377 | (format "#<%s %s%s>" (eieio--object-class-name obj) |
| 271 | (eieio--object-name obj) (or extra ""))) | 378 | (eieio-object-name-string obj) (or extra ""))) |
| 272 | (define-obsolete-function-alias 'object-name #'eieio-object-name "24.4") | 379 | (define-obsolete-function-alias 'object-name #'eieio-object-name "24.4") |
| 273 | 380 | ||
| 274 | (defun eieio-object-name-string (obj) "Return a string which is OBJ's name." | 381 | (defconst eieio--object-names (make-hash-table :test #'eq :weakness 'key)) |
| 275 | (eieio--check-type eieio-object-p obj) | 382 | |
| 276 | (eieio--object-name obj)) | 383 | ;; In the past, every EIEIO object had a `name' field, so we had the two method |
| 384 | ;; below "for free". Since this field is very rarely used, we got rid of it | ||
| 385 | ;; and instead we keep it in a weak hash-tables, for those very rare objects | ||
| 386 | ;; that use it. | ||
| 387 | (defmethod eieio-object-name-string (obj) | ||
| 388 | "Return a string which is OBJ's name." | ||
| 389 | (declare (obsolete eieio-named "25.1")) | ||
| 390 | (or (gethash obj eieio--object-names) | ||
| 391 | (symbol-name (eieio-object-class obj)))) | ||
| 277 | (define-obsolete-function-alias | 392 | (define-obsolete-function-alias |
| 278 | 'object-name-string #'eieio-object-name-string "24.4") | 393 | 'object-name-string #'eieio-object-name-string "24.4") |
| 279 | 394 | ||
| 280 | (defun eieio-object-set-name-string (obj name) | 395 | (defmethod eieio-object-set-name-string (obj name) |
| 281 | "Set the string which is OBJ's NAME." | 396 | "Set the string which is OBJ's NAME." |
| 282 | (eieio--check-type eieio-object-p obj) | 397 | (declare (obsolete eieio-named "25.1")) |
| 283 | (eieio--check-type stringp name) | 398 | (eieio--check-type stringp name) |
| 284 | (setf (eieio--object-name obj) name)) | 399 | (setf (gethash obj eieio--object-names) name)) |
| 285 | (define-obsolete-function-alias | 400 | (define-obsolete-function-alias |
| 286 | 'object-set-name-string 'eieio-object-set-name-string "24.4") | 401 | 'object-set-name-string 'eieio-object-set-name-string "24.4") |
| 287 | 402 | ||
| 288 | (defun eieio-object-class (obj) "Return the class struct defining OBJ." | 403 | (defun eieio-object-class (obj) |
| 404 | "Return the class struct defining OBJ." | ||
| 405 | ;; FIXME: We say we return a "struct" but we return a symbol instead! | ||
| 289 | (eieio--check-type eieio-object-p obj) | 406 | (eieio--check-type eieio-object-p obj) |
| 290 | (eieio--object-class obj)) | 407 | (eieio--object-class-name obj)) |
| 291 | (define-obsolete-function-alias 'object-class #'eieio-object-class "24.4") | 408 | (define-obsolete-function-alias 'object-class #'eieio-object-class "24.4") |
| 292 | ;; CLOS name, maybe? | 409 | ;; CLOS name, maybe? |
| 293 | (define-obsolete-function-alias 'class-of #'eieio-object-class "24.4") | 410 | (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." | |||
| 295 | (defun eieio-object-class-name (obj) | 412 | (defun eieio-object-class-name (obj) |
| 296 | "Return a Lisp like symbol name for OBJ's class." | 413 | "Return a Lisp like symbol name for OBJ's class." |
| 297 | (eieio--check-type eieio-object-p obj) | 414 | (eieio--check-type eieio-object-p obj) |
| 298 | (eieio-class-name (eieio--object-class obj))) | 415 | (eieio-class-name (eieio--object-class-name obj))) |
| 299 | (define-obsolete-function-alias | 416 | (define-obsolete-function-alias |
| 300 | 'object-class-name 'eieio-object-class-name "24.4") | 417 | 'object-class-name 'eieio-object-class-name "24.4") |
| 301 | 418 | ||
| @@ -303,15 +420,16 @@ If EXTRA, include that in the string returned to represent the symbol." | |||
| 303 | "Return parent classes to CLASS. (overload of variable). | 420 | "Return parent classes to CLASS. (overload of variable). |
| 304 | 421 | ||
| 305 | The CLOS function `class-direct-superclasses' is aliased to this function." | 422 | The CLOS function `class-direct-superclasses' is aliased to this function." |
| 306 | (eieio--check-type class-p class) | 423 | (let ((c (eieio-class-object class))) |
| 307 | (eieio-class-parents-fast class)) | 424 | (eieio--class-parent c))) |
| 425 | |||
| 308 | (define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4") | 426 | (define-obsolete-function-alias 'class-parents #'eieio-class-parents "24.4") |
| 309 | 427 | ||
| 310 | (defun eieio-class-children (class) | 428 | (defun eieio-class-children (class) |
| 311 | "Return child classes to CLASS. | 429 | "Return child classes to CLASS. |
| 312 | The CLOS function `class-direct-subclasses' is aliased to this function." | 430 | The CLOS function `class-direct-subclasses' is aliased to this function." |
| 313 | (eieio--check-type class-p class) | 431 | (eieio--check-type class-p class) |
| 314 | (eieio-class-children-fast class)) | 432 | (eieio--class-children (eieio--class-v class))) |
| 315 | (define-obsolete-function-alias | 433 | (define-obsolete-function-alias |
| 316 | 'class-children #'eieio-class-children "24.4") | 434 | 'class-children #'eieio-class-children "24.4") |
| 317 | 435 | ||
| @@ -326,38 +444,44 @@ The CLOS function `class-direct-subclasses' is aliased to this function." | |||
| 326 | `(car (eieio-class-parents ,class))) | 444 | `(car (eieio-class-parents ,class))) |
| 327 | (define-obsolete-function-alias 'class-parent 'eieio-class-parent "24.4") | 445 | (define-obsolete-function-alias 'class-parent 'eieio-class-parent "24.4") |
| 328 | 446 | ||
| 329 | (defun same-class-p (obj class) "Return t if OBJ is of class-type CLASS." | 447 | (defun same-class-p (obj class) |
| 330 | (eieio--check-type class-p class) | 448 | "Return t if OBJ is of class-type CLASS." |
| 449 | (setq class (eieio--class-object class)) | ||
| 450 | (eieio--check-type eieio--class-p class) | ||
| 331 | (eieio--check-type eieio-object-p obj) | 451 | (eieio--check-type eieio-object-p obj) |
| 332 | (same-class-fast-p obj class)) | 452 | (eq (eieio--object-class-object obj) class)) |
| 333 | 453 | ||
| 334 | (defun object-of-class-p (obj class) | 454 | (defun object-of-class-p (obj class) |
| 335 | "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses." | 455 | "Return non-nil if OBJ is an instance of CLASS or CLASS' subclasses." |
| 336 | (eieio--check-type eieio-object-p obj) | 456 | (eieio--check-type eieio-object-p obj) |
| 337 | ;; class will be checked one layer down | 457 | ;; class will be checked one layer down |
| 338 | (child-of-class-p (eieio--object-class obj) class)) | 458 | (child-of-class-p (eieio--object-class-object obj) class)) |
| 339 | ;; Backwards compatibility | 459 | ;; Backwards compatibility |
| 340 | (defalias 'obj-of-class-p 'object-of-class-p) | 460 | (defalias 'obj-of-class-p 'object-of-class-p) |
| 341 | 461 | ||
| 342 | (defun child-of-class-p (child class) | 462 | (defun child-of-class-p (child class) |
| 343 | "Return non-nil if CHILD class is a subclass of CLASS." | 463 | "Return non-nil if CHILD class is a subclass of CLASS." |
| 344 | (eieio--check-type class-p class) | 464 | (setq child (eieio--class-object child)) |
| 345 | (eieio--check-type class-p child) | 465 | (eieio--check-type eieio--class-p child) |
| 346 | (let ((p nil)) | 466 | ;; `eieio-default-superclass' is never mentioned in eieio--class-parent, |
| 347 | (while (and child (not (eq child class))) | 467 | ;; so we have to special case it here. |
| 348 | (setq p (append p (eieio--class-parent (class-v child))) | 468 | (or (eq class 'eieio-default-superclass) |
| 349 | child (car p) | 469 | (let ((p nil)) |
| 350 | p (cdr p))) | 470 | (setq class (eieio--class-object class)) |
| 351 | (if child t))) | 471 | (eieio--check-type eieio--class-p class) |
| 472 | (while (and child (not (eq child class))) | ||
| 473 | (setq p (append p (eieio--class-parent child)) | ||
| 474 | child (pop p))) | ||
| 475 | (if child t)))) | ||
| 352 | 476 | ||
| 353 | (defun object-slots (obj) | 477 | (defun object-slots (obj) |
| 354 | "Return list of slots available in OBJ." | 478 | "Return list of slots available in OBJ." |
| 355 | (eieio--check-type eieio-object-p obj) | 479 | (eieio--check-type eieio-object-p obj) |
| 356 | (eieio--class-public-a (class-v (eieio--object-class obj)))) | 480 | (eieio--class-public-a (eieio--object-class-object obj))) |
| 357 | 481 | ||
| 358 | (defun class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." | 482 | (defun eieio--class-slot-initarg (class slot) "Fetch from CLASS, SLOT's :initarg." |
| 359 | (eieio--check-type class-p class) | 483 | (eieio--check-type eieio--class-p class) |
| 360 | (let ((ia (eieio--class-initarg-tuples (class-v class))) | 484 | (let ((ia (eieio--class-initarg-tuples class)) |
| 361 | (f nil)) | 485 | (f nil)) |
| 362 | (while (and ia (not f)) | 486 | (while (and ia (not f)) |
| 363 | (if (eq (cdr (car ia)) slot) | 487 | (if (eq (cdr (car ia)) slot) |
| @@ -371,6 +495,7 @@ The CLOS function `class-direct-subclasses' is aliased to this function." | |||
| 371 | "Set the value in OBJ for slot SLOT to VALUE. | 495 | "Set the value in OBJ for slot SLOT to VALUE. |
| 372 | SLOT is the slot name as specified in `defclass' or the tag created | 496 | SLOT is the slot name as specified in `defclass' or the tag created |
| 373 | with in the :initarg slot. VALUE can be any Lisp object." | 497 | with in the :initarg slot. VALUE can be any Lisp object." |
| 498 | (declare (debug (form symbolp form))) | ||
| 374 | `(eieio-oset ,obj (quote ,slot) ,value)) | 499 | `(eieio-oset ,obj (quote ,slot) ,value)) |
| 375 | 500 | ||
| 376 | (defmacro oset-default (class slot value) | 501 | (defmacro oset-default (class slot value) |
| @@ -378,6 +503,7 @@ with in the :initarg slot. VALUE can be any Lisp object." | |||
| 378 | The default value is usually set with the :initform tag during class | 503 | The default value is usually set with the :initform tag during class |
| 379 | creation. This allows users to change the default behavior of classes | 504 | creation. This allows users to change the default behavior of classes |
| 380 | after they are created." | 505 | after they are created." |
| 506 | (declare (debug (form symbolp form))) | ||
| 381 | `(eieio-oset-default ,class (quote ,slot) ,value)) | 507 | `(eieio-oset-default ,class (quote ,slot) ,value)) |
| 382 | 508 | ||
| 383 | ;;; CLOS queries into classes and slots | 509 | ;;; CLOS queries into classes and slots |
| @@ -402,11 +528,9 @@ OBJECT can be an instance or a class." | |||
| 402 | 528 | ||
| 403 | (defun slot-exists-p (object-or-class slot) | 529 | (defun slot-exists-p (object-or-class slot) |
| 404 | "Return non-nil if OBJECT-OR-CLASS has SLOT." | 530 | "Return non-nil if OBJECT-OR-CLASS has SLOT." |
| 405 | (let ((cv (class-v (cond ((eieio-object-p object-or-class) | 531 | (let ((cv (cond ((eieio-object-p object-or-class) |
| 406 | (eieio-object-class object-or-class)) | 532 | (eieio--object-class-object object-or-class)) |
| 407 | ((class-p object-or-class) | 533 | (t (eieio-class-object object-or-class))))) |
| 408 | object-or-class)) | ||
| 409 | ))) | ||
| 410 | (or (memq slot (eieio--class-public-a cv)) | 534 | (or (memq slot (eieio--class-public-a cv)) |
| 411 | (memq slot (eieio--class-class-allocation-a cv))) | 535 | (memq slot (eieio--class-class-allocation-a cv))) |
| 412 | )) | 536 | )) |
| @@ -418,7 +542,7 @@ If ERRORP is non-nil, `wrong-argument-type' is signaled." | |||
| 418 | (if (not (class-p symbol)) | 542 | (if (not (class-p symbol)) |
| 419 | (if errorp (signal 'wrong-type-argument (list 'class-p symbol)) | 543 | (if errorp (signal 'wrong-type-argument (list 'class-p symbol)) |
| 420 | nil) | 544 | nil) |
| 421 | (class-v symbol))) | 545 | (eieio--class-v symbol))) |
| 422 | 546 | ||
| 423 | ;;; Slightly more complex utility functions for objects | 547 | ;;; Slightly more complex utility functions for objects |
| 424 | ;; | 548 | ;; |
| @@ -496,44 +620,6 @@ If SLOT is unbound, do nothing." | |||
| 496 | nil | 620 | nil |
| 497 | (eieio-oset object slot (delete item (eieio-oref object slot))))) | 621 | (eieio-oset object slot (delete item (eieio-oref object slot))))) |
| 498 | 622 | ||
| 499 | ;;; | ||
| 500 | ;; Method Calling Functions | ||
| 501 | |||
| 502 | (defun next-method-p () | ||
| 503 | "Return non-nil if there is a next method. | ||
| 504 | Returns a list of lambda expressions which is the `next-method' | ||
| 505 | order." | ||
| 506 | eieio-generic-call-next-method-list) | ||
| 507 | |||
| 508 | (defun call-next-method (&rest replacement-args) | ||
| 509 | "Call the superclass method from a subclass method. | ||
| 510 | The superclass method is specified in the current method list, | ||
| 511 | and is called the next method. | ||
| 512 | |||
| 513 | If REPLACEMENT-ARGS is non-nil, then use them instead of | ||
| 514 | `eieio-generic-call-arglst'. The generic arg list are the | ||
| 515 | arguments passed in at the top level. | ||
| 516 | |||
| 517 | Use `next-method-p' to find out if there is a next method to call." | ||
| 518 | (if (not (eieio--scoped-class)) | ||
| 519 | (error "`call-next-method' not called within a class specific method")) | ||
| 520 | (if (and (/= eieio-generic-call-key method-primary) | ||
| 521 | (/= eieio-generic-call-key method-static)) | ||
| 522 | (error "Cannot `call-next-method' except in :primary or :static methods") | ||
| 523 | ) | ||
| 524 | (let ((newargs (or replacement-args eieio-generic-call-arglst)) | ||
| 525 | (next (car eieio-generic-call-next-method-list)) | ||
| 526 | ) | ||
| 527 | (if (or (not next) (not (car next))) | ||
| 528 | (apply #'no-next-method (car newargs) (cdr newargs)) | ||
| 529 | (let* ((eieio-generic-call-next-method-list | ||
| 530 | (cdr eieio-generic-call-next-method-list)) | ||
| 531 | (eieio-generic-call-arglst newargs) | ||
| 532 | (fcn (car next)) | ||
| 533 | ) | ||
| 534 | (eieio--with-scoped-class (cdr next) | ||
| 535 | (apply fcn newargs)) )))) | ||
| 536 | |||
| 537 | ;;; Here are some CLOS items that need the CL package | 623 | ;;; Here are some CLOS items that need the CL package |
| 538 | ;; | 624 | ;; |
| 539 | 625 | ||
| @@ -556,22 +642,23 @@ Its slots are automatically adopted by classes with no specified parents. | |||
| 556 | This class is not stored in the `parent' slot of a class vector." | 642 | This class is not stored in the `parent' slot of a class vector." |
| 557 | :abstract t) | 643 | :abstract t) |
| 558 | 644 | ||
| 645 | (setq eieio-default-superclass (eieio--class-v 'eieio-default-superclass)) | ||
| 646 | |||
| 559 | (defalias 'standard-class 'eieio-default-superclass) | 647 | (defalias 'standard-class 'eieio-default-superclass) |
| 560 | 648 | ||
| 561 | (defgeneric constructor (class newname &rest slots) | 649 | (defgeneric eieio-constructor (class &rest slots) |
| 562 | "Default constructor for CLASS `eieio-default-superclass'.") | 650 | "Default constructor for CLASS `eieio-default-superclass'.") |
| 563 | 651 | ||
| 564 | (defmethod constructor :static | 652 | (define-obsolete-function-alias 'constructor #'eieio-constructor "25.1") |
| 565 | ((class eieio-default-superclass) newname &rest slots) | 653 | |
| 654 | (defmethod eieio-constructor :static | ||
| 655 | ((class eieio-default-superclass) &rest slots) | ||
| 566 | "Default constructor for CLASS `eieio-default-superclass'. | 656 | "Default constructor for CLASS `eieio-default-superclass'. |
| 567 | NEWNAME is the name to be given to the constructed object. | ||
| 568 | SLOTS are the initialization slots used by `shared-initialize'. | 657 | SLOTS are the initialization slots used by `shared-initialize'. |
| 569 | This static method is called when an object is constructed. | 658 | This static method is called when an object is constructed. |
| 570 | It allocates the vector used to represent an EIEIO object, and then | 659 | It allocates the vector used to represent an EIEIO object, and then |
| 571 | calls `shared-initialize' on that object." | 660 | calls `shared-initialize' on that object." |
| 572 | (let* ((new-object (copy-sequence (eieio--class-default-object-cache (class-v class))))) | 661 | (let* ((new-object (copy-sequence (eieio--class-default-object-cache (eieio--class-v class))))) |
| 573 | ;; Update the name for the newly created object. | ||
| 574 | (setf (eieio--object-name new-object) newname) | ||
| 575 | ;; Call the initialize method on the new object with the slots | 662 | ;; Call the initialize method on the new object with the slots |
| 576 | ;; that were passed down to us. | 663 | ;; that were passed down to us. |
| 577 | (initialize-instance new-object slots) | 664 | (initialize-instance new-object slots) |
| @@ -585,10 +672,10 @@ Called from the constructor routine.") | |||
| 585 | (defmethod shared-initialize ((obj eieio-default-superclass) slots) | 672 | (defmethod shared-initialize ((obj eieio-default-superclass) slots) |
| 586 | "Set slots of OBJ with SLOTS which is a list of name/value pairs. | 673 | "Set slots of OBJ with SLOTS which is a list of name/value pairs. |
| 587 | Called from the constructor routine." | 674 | Called from the constructor routine." |
| 588 | (eieio--with-scoped-class (eieio--object-class obj) | 675 | (eieio--with-scoped-class (eieio--object-class-object obj) |
| 589 | (while slots | 676 | (while slots |
| 590 | (let ((rn (eieio-initarg-to-attribute (eieio--object-class obj) | 677 | (let ((rn (eieio--initarg-to-attribute (eieio--object-class-object obj) |
| 591 | (car slots)))) | 678 | (car slots)))) |
| 592 | (if (not rn) | 679 | (if (not rn) |
| 593 | (slot-missing obj (car slots) 'oset (car (cdr slots))) | 680 | (slot-missing obj (car slots) 'oset (car (cdr slots))) |
| 594 | (eieio-oset obj rn (car (cdr slots))))) | 681 | (eieio-oset obj rn (car (cdr slots))))) |
| @@ -609,7 +696,7 @@ not taken, then new objects of your class will not have their values | |||
| 609 | dynamically set from SLOTS." | 696 | dynamically set from SLOTS." |
| 610 | ;; First, see if any of our defaults are `lambda', and | 697 | ;; First, see if any of our defaults are `lambda', and |
| 611 | ;; re-evaluate them and apply the value to our slots. | 698 | ;; re-evaluate them and apply the value to our slots. |
| 612 | (let* ((this-class (class-v (eieio--object-class this))) | 699 | (let* ((this-class (eieio--object-class-object this)) |
| 613 | (slot (eieio--class-public-a this-class)) | 700 | (slot (eieio--class-public-a this-class)) |
| 614 | (defaults (eieio--class-public-d this-class))) | 701 | (defaults (eieio--class-public-d this-class))) |
| 615 | (while slot | 702 | (while slot |
| @@ -662,34 +749,6 @@ EIEIO can only dispatch on the first argument, so the first two are swapped." | |||
| 662 | (signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name object) | 749 | (signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name object) |
| 663 | slot-name fn))) | 750 | slot-name fn))) |
| 664 | 751 | ||
| 665 | (defgeneric no-applicable-method (object method &rest args) | ||
| 666 | "Called if there are no implementations for OBJECT in METHOD.") | ||
| 667 | |||
| 668 | (defmethod no-applicable-method ((object eieio-default-superclass) | ||
| 669 | method &rest _args) | ||
| 670 | "Called if there are no implementations for OBJECT in METHOD. | ||
| 671 | OBJECT is the object which has no method implementation. | ||
| 672 | ARGS are the arguments that were passed to METHOD. | ||
| 673 | |||
| 674 | Implement this for a class to block this signal. The return | ||
| 675 | value becomes the return value of the original method call." | ||
| 676 | (signal 'no-method-definition (list method (eieio-object-name object))) | ||
| 677 | ) | ||
| 678 | |||
| 679 | (defgeneric no-next-method (object &rest args) | ||
| 680 | "Called from `call-next-method' when no additional methods are available.") | ||
| 681 | |||
| 682 | (defmethod no-next-method ((object eieio-default-superclass) | ||
| 683 | &rest args) | ||
| 684 | "Called from `call-next-method' when no additional methods are available. | ||
| 685 | OBJECT is othe object being called on `call-next-method'. | ||
| 686 | ARGS are the arguments it is called by. | ||
| 687 | This method signals `no-next-method' by default. Override this | ||
| 688 | method to not throw an error, and its return value becomes the | ||
| 689 | return value of `call-next-method'." | ||
| 690 | (signal 'no-next-method (list (eieio-object-name object) args)) | ||
| 691 | ) | ||
| 692 | |||
| 693 | (defgeneric clone (obj &rest params) | 752 | (defgeneric clone (obj &rest params) |
| 694 | "Make a copy of OBJ, and then supply PARAMS. | 753 | "Make a copy of OBJ, and then supply PARAMS. |
| 695 | PARAMS is a parameter list of the same form used by `initialize-instance'. | 754 | PARAMS is a parameter list of the same form used by `initialize-instance'. |
| @@ -699,18 +758,11 @@ first and modify the returned object.") | |||
| 699 | 758 | ||
| 700 | (defmethod clone ((obj eieio-default-superclass) &rest params) | 759 | (defmethod clone ((obj eieio-default-superclass) &rest params) |
| 701 | "Make a copy of OBJ, and then apply PARAMS." | 760 | "Make a copy of OBJ, and then apply PARAMS." |
| 702 | (let ((nobj (copy-sequence obj)) | 761 | (let ((nobj (copy-sequence obj))) |
| 703 | (nm (eieio--object-name obj)) | 762 | (if (stringp (car params)) |
| 704 | (passname (and params (stringp (car params)))) | 763 | (funcall (if eieio-backward-compatibility #'ignore #'message) |
| 705 | (num 1)) | 764 | "Obsolete name %S passed to clone" (pop params))) |
| 706 | (if params (shared-initialize nobj (if passname (cdr params) params))) | 765 | (if params (shared-initialize nobj params)) |
| 707 | (if (not passname) | ||
| 708 | (save-match-data | ||
| 709 | (if (string-match "-\\([0-9]+\\)" nm) | ||
| 710 | (setq num (1+ (string-to-number (match-string 1 nm))) | ||
| 711 | nm (substring nm 0 (match-beginning 0)))) | ||
| 712 | (setf (eieio--object-name nobj) (concat nm "-" (int-to-string num)))) | ||
| 713 | (setf (eieio--object-name nobj) (car params))) | ||
| 714 | nobj)) | 766 | nobj)) |
| 715 | 767 | ||
| 716 | (defgeneric destructor (this &rest params) | 768 | (defgeneric destructor (this &rest params) |
| @@ -764,7 +816,7 @@ this object." | |||
| 764 | (princ comment) | 816 | (princ comment) |
| 765 | (princ "\n")) | 817 | (princ "\n")) |
| 766 | (let* ((cl (eieio-object-class this)) | 818 | (let* ((cl (eieio-object-class this)) |
| 767 | (cv (class-v cl))) | 819 | (cv (eieio--class-v cl))) |
| 768 | ;; Now output readable lisp to recreate this object | 820 | ;; Now output readable lisp to recreate this object |
| 769 | ;; It should look like this: | 821 | ;; It should look like this: |
| 770 | ;; (<constructor> <name> <slot> <slot> ... ) | 822 | ;; (<constructor> <name> <slot> <slot> ... ) |
| @@ -782,7 +834,7 @@ this object." | |||
| 782 | (eieio-print-depth (1+ eieio-print-depth))) | 834 | (eieio-print-depth (1+ eieio-print-depth))) |
| 783 | (while publa | 835 | (while publa |
| 784 | (when (slot-boundp this (car publa)) | 836 | (when (slot-boundp this (car publa)) |
| 785 | (let ((i (class-slot-initarg cl (car publa))) | 837 | (let ((i (eieio--class-slot-initarg cv (car publa))) |
| 786 | (v (eieio-oref this (car publa))) | 838 | (v (eieio-oref this (car publa))) |
| 787 | ) | 839 | ) |
| 788 | (unless (or (not i) (equal v (car publd))) | 840 | (unless (or (not i) (equal v (car publd))) |
| @@ -848,7 +900,6 @@ of `eq'." | |||
| 848 | (error "EIEIO: `change-class' is unimplemented")) | 900 | (error "EIEIO: `change-class' is unimplemented")) |
| 849 | 901 | ||
| 850 | ;; Hook ourselves into help system for describing classes and methods. | 902 | ;; Hook ourselves into help system for describing classes and methods. |
| 851 | (add-hook 'help-fns-describe-function-functions 'eieio-help-generic) | ||
| 852 | (add-hook 'help-fns-describe-function-functions 'eieio-help-constructor) | 903 | (add-hook 'help-fns-describe-function-functions 'eieio-help-constructor) |
| 853 | 904 | ||
| 854 | ;;; Interfacing with edebug | 905 | ;;; Interfacing with edebug |
| @@ -859,43 +910,23 @@ of `eq'." | |||
| 859 | Used as advice around `edebug-prin1-to-string', held in the | 910 | Used as advice around `edebug-prin1-to-string', held in the |
| 860 | variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to | 911 | variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to |
| 861 | `prin1-to-string' when appropriate." | 912 | `prin1-to-string' when appropriate." |
| 862 | (cond ((class-p object) (eieio-class-name object)) | 913 | (cond ((eieio--class-p object) (eieio-class-name object)) |
| 863 | ((eieio-object-p object) (object-print object)) | 914 | ((eieio-object-p object) (object-print object)) |
| 864 | ((and (listp object) (or (class-p (car object)) | 915 | ((and (listp object) (or (eieio--class-p (car object)) |
| 865 | (eieio-object-p (car object)))) | 916 | (eieio-object-p (car object)))) |
| 866 | (concat "(" (mapconcat #'eieio-edebug-prin1-to-string object " ") | 917 | (concat "(" (mapconcat |
| 918 | (lambda (x) (eieio-edebug-prin1-to-string print-function x)) | ||
| 919 | object " ") | ||
| 867 | ")")) | 920 | ")")) |
| 868 | (t (funcall print-function object noescape)))) | 921 | (t (funcall print-function object noescape)))) |
| 869 | 922 | ||
| 870 | (add-hook 'edebug-setup-hook | 923 | (advice-add 'edebug-prin1-to-string |
| 871 | (lambda () | 924 | :around #'eieio-edebug-prin1-to-string) |
| 872 | (def-edebug-spec defmethod | ||
| 873 | (&define ; this means we are defining something | ||
| 874 | [&or name ("setf" :name setf name)] | ||
| 875 | ;; ^^ This is the methods symbol | ||
| 876 | [ &optional symbolp ] ; this is key :before etc | ||
| 877 | list ; arguments | ||
| 878 | [ &optional stringp ] ; documentation string | ||
| 879 | def-body ; part to be debugged | ||
| 880 | )) | ||
| 881 | ;; The rest of the macros | ||
| 882 | (def-edebug-spec oref (form quote)) | ||
| 883 | (def-edebug-spec oref-default (form quote)) | ||
| 884 | (def-edebug-spec oset (form quote form)) | ||
| 885 | (def-edebug-spec oset-default (form quote form)) | ||
| 886 | (def-edebug-spec class-v form) | ||
| 887 | (def-edebug-spec class-p form) | ||
| 888 | (def-edebug-spec eieio-object-p form) | ||
| 889 | (def-edebug-spec class-constructor form) | ||
| 890 | (def-edebug-spec generic-p form) | ||
| 891 | (def-edebug-spec with-slots (list list def-body)) | ||
| 892 | (advice-add 'edebug-prin1-to-string | ||
| 893 | :around #'eieio-edebug-prin1-to-string))) | ||
| 894 | 925 | ||
| 895 | 926 | ||
| 896 | ;;; Start of automatically extracted autoloads. | 927 | ;;; Start of automatically extracted autoloads. |
| 897 | 928 | ||
| 898 | ;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "62709d76ae43f4fe70ed922391f9c64d") | 929 | ;;;### (autoloads nil "eieio-custom" "eieio-custom.el" "9a908efef1720439feb6323c1dd01770") |
| 899 | ;;; Generated autoloads from eieio-custom.el | 930 | ;;; Generated autoloads from eieio-custom.el |
| 900 | 931 | ||
| 901 | (autoload 'customize-object "eieio-custom" "\ | 932 | (autoload 'customize-object "eieio-custom" "\ |
| @@ -906,7 +937,7 @@ Optional argument GROUP is the sub-group of slots to display. | |||
| 906 | 937 | ||
| 907 | ;;;*** | 938 | ;;;*** |
| 908 | 939 | ||
| 909 | ;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "76058d02377b677eed3d15c28fc7ab21") | 940 | ;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "e922bf7ebc7dcb272480c4ba148da1ac") |
| 910 | ;;; Generated autoloads from eieio-opt.el | 941 | ;;; Generated autoloads from eieio-opt.el |
| 911 | 942 | ||
| 912 | (autoload 'eieio-browse "eieio-opt" "\ | 943 | (autoload 'eieio-browse "eieio-opt" "\ |
| @@ -927,11 +958,6 @@ Describe CTR if it is a class constructor. | |||
| 927 | 958 | ||
| 928 | \(fn CTR)" nil nil) | 959 | \(fn CTR)" nil nil) |
| 929 | 960 | ||
| 930 | (autoload 'eieio-help-generic "eieio-opt" "\ | ||
| 931 | Describe GENERIC if it is a generic function. | ||
| 932 | |||
| 933 | \(fn GENERIC)" nil nil) | ||
| 934 | |||
| 935 | ;;;*** | 961 | ;;;*** |
| 936 | 962 | ||
| 937 | ;;; End of automatically extracted autoloads. | 963 | ;;; End of automatically extracted autoloads. |
diff --git a/lisp/files.el b/lisp/files.el index 80b538c3267..1533c35e6ca 100644 --- a/lisp/files.el +++ b/lisp/files.el | |||
| @@ -729,38 +729,6 @@ The path separator is colon in GNU and GNU-like systems." | |||
| 729 | (lambda (f) (and (file-directory-p f) 'dir-ok))) | 729 | (lambda (f) (and (file-directory-p f) 'dir-ok))) |
| 730 | (error "No such directory found via CDPATH environment variable")))) | 730 | (error "No such directory found via CDPATH environment variable")))) |
| 731 | 731 | ||
| 732 | (defun file-tree-walk (dir action &rest args) | ||
| 733 | "Walk DIR executing ACTION on each file, with ARGS as additional arguments. | ||
| 734 | For each file, the function calls ACTION as follows: | ||
| 735 | |||
| 736 | \(ACTION DIRECTORY BASENAME ARGS\) | ||
| 737 | |||
| 738 | Where DIRECTORY is the leading directory of the file, | ||
| 739 | BASENAME is the basename of the file, | ||
| 740 | and ARGS are as specified in the call to this function, or nil if omitted. | ||
| 741 | |||
| 742 | The ACTION is applied to each subdirectory before descending into | ||
| 743 | it, and if nil is returned at that point, the descent will be | ||
| 744 | prevented. Directory entries are sorted with string-lessp." | ||
| 745 | (cond ((file-directory-p dir) | ||
| 746 | (setq dir (file-name-as-directory dir)) | ||
| 747 | (let ((lst (directory-files dir nil nil t)) | ||
| 748 | fullname file) | ||
| 749 | (while lst | ||
| 750 | (setq file (car lst)) | ||
| 751 | (setq lst (cdr lst)) | ||
| 752 | (cond ((member file '("." ".."))) | ||
| 753 | (t | ||
| 754 | (and (apply action dir file args) | ||
| 755 | (setq fullname (concat dir file)) | ||
| 756 | (file-directory-p fullname) | ||
| 757 | (apply 'file-tree-walk fullname action args))))))) | ||
| 758 | (t | ||
| 759 | (apply action | ||
| 760 | (file-name-directory dir) | ||
| 761 | (file-name-nondirectory dir) | ||
| 762 | args)))) | ||
| 763 | |||
| 764 | (defsubst directory-name-p (name) | 732 | (defsubst directory-name-p (name) |
| 765 | "Return non-nil if NAME ends with a slash character." | 733 | "Return non-nil if NAME ends with a slash character." |
| 766 | (and (> (length name) 0) | 734 | (and (> (length name) 0) |
diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 73a0de76a1f..20de9aea136 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog | |||
| @@ -1,3 +1,7 @@ | |||
| 1 | 2015-01-08 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 2 | |||
| 3 | * registry.el: Don't use <class> as a variable. | ||
| 4 | |||
| 1 | 2014-12-29 Paul Eggert <eggert@cs.ucla.edu> | 5 | 2014-12-29 Paul Eggert <eggert@cs.ucla.edu> |
| 2 | 6 | ||
| 3 | * message.el (message-make-fqdn): | 7 | * message.el (message-make-fqdn): |
| @@ -10,6 +14,12 @@ | |||
| 10 | * mm-decode.el (mm-shr): Bind `shr-width' to `fill-column' so that | 14 | * mm-decode.el (mm-shr): Bind `shr-width' to `fill-column' so that |
| 11 | lines don't get overlong when responding. | 15 | lines don't get overlong when responding. |
| 12 | 16 | ||
| 17 | 2014-12-19 Andreas Schwab <schwab@linux-m68k.org> | ||
| 18 | |||
| 19 | * gnus-group.el (gnus-read-ephemeral-bug-group): | ||
| 20 | Bind coding-system-for-read and coding-system-for-write only around | ||
| 21 | with-temp-file, and make buffer unibyte. Don't write temp file twice. | ||
| 22 | |||
| 13 | 2014-12-18 Paul Eggert <eggert@cs.ucla.edu> | 23 | 2014-12-18 Paul Eggert <eggert@cs.ucla.edu> |
| 14 | 24 | ||
| 15 | * registry.el (registry-db): Set default slot later. | 25 | * registry.el (registry-db): Set default slot later. |
| @@ -67,9 +77,9 @@ | |||
| 67 | 77 | ||
| 68 | 2014-12-09 Lars Magne Ingebrigtsen <larsi@gnus.org> | 78 | 2014-12-09 Lars Magne Ingebrigtsen <larsi@gnus.org> |
| 69 | 79 | ||
| 70 | * gnus-art.el (gnus-article-mime-handles): Refactored out into own | 80 | * gnus-art.el (gnus-article-mime-handles): Refactor out into own |
| 71 | function for reuse. | 81 | function for reuse. |
| 72 | (gnus-mime-buttonize-attachments-in-header): Adjusted. | 82 | (gnus-mime-buttonize-attachments-in-header): Adjust. |
| 73 | 83 | ||
| 74 | 2014-12-07 Lars Magne Ingebrigtsen <larsi@gnus.org> | 84 | 2014-12-07 Lars Magne Ingebrigtsen <larsi@gnus.org> |
| 75 | 85 | ||
diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 29c380f8234..f3dcc40b8c4 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el | |||
| @@ -2455,27 +2455,27 @@ the bug number, and browsing the URL must return mbox output." | |||
| 2455 | (setq ids (string-to-number ids))) | 2455 | (setq ids (string-to-number ids))) |
| 2456 | (unless (listp ids) | 2456 | (unless (listp ids) |
| 2457 | (setq ids (list ids))) | 2457 | (setq ids (list ids))) |
| 2458 | (let ((tmpfile (mm-make-temp-file "gnus-temp-group-")) | 2458 | (let ((tmpfile (mm-make-temp-file "gnus-temp-group-"))) |
| 2459 | (coding-system-for-write 'binary) | 2459 | (let ((coding-system-for-write 'binary) |
| 2460 | (coding-system-for-read 'binary)) | 2460 | (coding-system-for-read 'binary)) |
| 2461 | (with-temp-file tmpfile | 2461 | (with-temp-file tmpfile |
| 2462 | (dolist (id ids) | 2462 | (mm-disable-multibyte) |
| 2463 | (url-insert-file-contents (format mbox-url id))) | 2463 | (dolist (id ids) |
| 2464 | (goto-char (point-min)) | 2464 | (url-insert-file-contents (format mbox-url id))) |
| 2465 | ;; Add the debbugs address so that we can respond to reports easily. | 2465 | (goto-char (point-min)) |
| 2466 | (while (re-search-forward "^To: " nil t) | 2466 | ;; Add the debbugs address so that we can respond to reports easily. |
| 2467 | (end-of-line) | 2467 | (while (re-search-forward "^To: " nil t) |
| 2468 | (insert (format ", %s@%s" (car ids) | 2468 | (end-of-line) |
| 2469 | (gnus-replace-in-string | 2469 | (insert (format ", %s@%s" (car ids) |
| 2470 | (gnus-replace-in-string mbox-url "^http://" "") | 2470 | (gnus-replace-in-string |
| 2471 | "/.*$" "")))) | 2471 | (gnus-replace-in-string mbox-url "^http://" "") |
| 2472 | (write-region (point-min) (point-max) tmpfile) | 2472 | "/.*$" "")))))) |
| 2473 | (gnus-group-read-ephemeral-group | 2473 | (gnus-group-read-ephemeral-group |
| 2474 | (format "nndoc+ephemeral:bug#%s" | 2474 | (format "nndoc+ephemeral:bug#%s" |
| 2475 | (mapconcat 'number-to-string ids ",")) | 2475 | (mapconcat 'number-to-string ids ",")) |
| 2476 | `(nndoc ,tmpfile | 2476 | `(nndoc ,tmpfile |
| 2477 | (nndoc-article-type mbox)) | 2477 | (nndoc-article-type mbox)) |
| 2478 | nil window-conf)) | 2478 | nil window-conf) |
| 2479 | (delete-file tmpfile))) | 2479 | (delete-file tmpfile))) |
| 2480 | 2480 | ||
| 2481 | (defun gnus-read-ephemeral-debian-bug-group (number) | 2481 | (defun gnus-read-ephemeral-debian-bug-group (number) |
diff --git a/lisp/gnus/registry.el b/lisp/gnus/registry.el index b3a2abfe26f..55b83a8e889 100644 --- a/lisp/gnus/registry.el +++ b/lisp/gnus/registry.el | |||
| @@ -124,7 +124,7 @@ | |||
| 124 | :type hash-table | 124 | :type hash-table |
| 125 | :documentation "The data hashtable."))) | 125 | :documentation "The data hashtable."))) |
| 126 | ;; Do this separately, since defclass doesn't allow expressions in :initform. | 126 | ;; Do this separately, since defclass doesn't allow expressions in :initform. |
| 127 | (oset-default registry-db max-size most-positive-fixnum) | 127 | (oset-default 'registry-db max-size most-positive-fixnum) |
| 128 | 128 | ||
| 129 | (defmethod initialize-instance :BEFORE ((this registry-db) slots) | 129 | (defmethod initialize-instance :BEFORE ((this registry-db) slots) |
| 130 | "Check whether a registry object needs to be upgraded." | 130 | "Check whether a registry object needs to be upgraded." |
diff --git a/lisp/international/ccl.el b/lisp/international/ccl.el index 9eb091f80c1..429c14b5e44 100644 --- a/lisp/international/ccl.el +++ b/lisp/international/ccl.el | |||
| @@ -1355,6 +1355,14 @@ IF := (if EXPRESSION CCL_BLOCK_0 CCL_BLOCK_1) | |||
| 1355 | BRANCH := (branch EXPRESSION CCL_BLOCK_0 [CCL_BLOCK_1 ...]) | 1355 | BRANCH := (branch EXPRESSION CCL_BLOCK_0 [CCL_BLOCK_1 ...]) |
| 1356 | 1356 | ||
| 1357 | ;; Execute STATEMENTs until (break) or (end) is executed. | 1357 | ;; Execute STATEMENTs until (break) or (end) is executed. |
| 1358 | |||
| 1359 | ;; Create a block of STATEMENTs for repeating. The STATEMENTs | ||
| 1360 | ;; are executed sequentially until REPEAT or BREAK is executed. | ||
| 1361 | ;; If REPEAT statement is executed, STATEMENTs are executed from the | ||
| 1362 | ;; start again. If BREAK statements is executed, the execution | ||
| 1363 | ;; exits from the block. If neither REPEAT nor BREAK is | ||
| 1364 | ;; executed, the execution exits from the block after executing the | ||
| 1365 | ;; last STATEMENT. | ||
| 1358 | LOOP := (loop STATEMENT [STATEMENT ...]) | 1366 | LOOP := (loop STATEMENT [STATEMENT ...]) |
| 1359 | 1367 | ||
| 1360 | ;; Terminate the most inner loop. | 1368 | ;; Terminate the most inner loop. |
| @@ -1501,17 +1509,42 @@ ARRAY := `[' integer ... `]' | |||
| 1501 | 1509 | ||
| 1502 | 1510 | ||
| 1503 | TRANSLATE := | 1511 | TRANSLATE := |
| 1504 | (translate-character REG(table) REG(charset) REG(codepoint)) | 1512 | ;; Decode character SRC, translate it by translate table |
| 1505 | | (translate-character SYMBOL REG(charset) REG(codepoint)) | 1513 | ;; TABLE, and encode it back to DST. TABLE is specified |
| 1506 | ;; SYMBOL must refer to a table defined by `define-translation-table'. | 1514 | ;; by its id number in REG_0, SRC is specified by its |
| 1515 | ;; charset id number and codepoint in REG_1 and REG_2 | ||
| 1516 | ;; respectively. | ||
| 1517 | ;; On encoding, the charset of highest priority is selected. | ||
| 1518 | ;; After the execution, DST is specified by its charset | ||
| 1519 | ;; id number and codepoint in REG_1 and REG_2 respectively. | ||
| 1520 | (translate-character REG_0 REG_1 REG_2) | ||
| 1521 | |||
| 1522 | ;; Same as above except for SYMBOL specifying the name of | ||
| 1523 | ;; the translate table defined by `define-translation-table'. | ||
| 1524 | | (translate-character SYMBOL REG_1 REG_2) | ||
| 1525 | |||
| 1507 | LOOKUP := | 1526 | LOOKUP := |
| 1508 | (lookup-character SYMBOL REG(charset) REG(codepoint)) | 1527 | ;; Look up character SRC in hash table TABLE. TABLE is |
| 1528 | ;; specified by its name in SYMBOL, and SRC is specified by | ||
| 1529 | ;; its charset id number and codepoint in REG_1 and REG_2 | ||
| 1530 | ;; respectively. | ||
| 1531 | ;; If its associated value is an integer, set REG_1 to that | ||
| 1532 | ;; value, and set r7 to 1. Otherwise, set r7 to 0. | ||
| 1533 | (lookup-character SYMBOL REG_1 REG_2) | ||
| 1534 | |||
| 1535 | ;; Look up integer value N in hash table TABLE. TABLE is | ||
| 1536 | ;; specified by its name in SYMBOL and N is specified in | ||
| 1537 | ;; REG. | ||
| 1538 | ;; If its associated value is a character, set REG to that | ||
| 1539 | ;; value, and set r7 to 1. Otherwise, set r7 to 0. | ||
| 1509 | | (lookup-integer SYMBOL REG(integer)) | 1540 | | (lookup-integer SYMBOL REG(integer)) |
| 1510 | ;; SYMBOL refers to a table defined by `define-translation-hash-table'. | 1541 | |
| 1511 | MAP := | 1542 | MAP := |
| 1512 | (iterate-multiple-map REG REG MAP-IDs) | 1543 | ;; The following statements are for internal use only. |
| 1513 | | (map-multiple REG REG (MAP-SET)) | 1544 | (iterate-multiple-map REG REG MAP-IDs) |
| 1514 | | (map-single REG REG MAP-ID) | 1545 | | (map-multiple REG REG (MAP-SET)) |
| 1546 | | (map-single REG REG MAP-ID) | ||
| 1547 | |||
| 1515 | MAP-IDs := MAP-ID ... | 1548 | MAP-IDs := MAP-ID ... |
| 1516 | MAP-SET := MAP-IDs | (MAP-IDs) MAP-SET | 1549 | MAP-SET := MAP-IDs | (MAP-IDs) MAP-SET |
| 1517 | MAP-ID := integer | 1550 | MAP-ID := integer |
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index 16312444e3c..538bd974256 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el | |||
| @@ -826,16 +826,27 @@ styles for specific categories, such as files, buffers, etc." | |||
| 826 | :type completion--styles-type | 826 | :type completion--styles-type |
| 827 | :version "23.1") | 827 | :version "23.1") |
| 828 | 828 | ||
| 829 | (defcustom completion-category-overrides | 829 | (defvar completion-category-defaults |
| 830 | '((buffer (styles . (basic substring)))) | 830 | '((buffer (styles . (basic substring))) |
| 831 | "List of `completion-styles' overrides for specific categories. | 831 | (unicode-name (styles . (basic substring)))) |
| 832 | "Default settings for specific completion categories. | ||
| 833 | Each entry has the shape (CATEGORY . ALIST) where ALIST is | ||
| 834 | an association list that can specify properties such as: | ||
| 835 | - `styles': the list of `completion-styles' to use for that category. | ||
| 836 | - `cycle': the `completion-cycle-threshold' to use for that category. | ||
| 837 | Categories are symbols such as `buffer' and `file', used when | ||
| 838 | completing buffer and file names, respectively.") | ||
| 839 | |||
| 840 | (defcustom completion-category-overrides nil | ||
| 841 | "List of category-specific user overrides for completion styles. | ||
| 832 | Each override has the shape (CATEGORY . ALIST) where ALIST is | 842 | Each override has the shape (CATEGORY . ALIST) where ALIST is |
| 833 | an association list that can specify properties such as: | 843 | an association list that can specify properties such as: |
| 834 | - `styles': the list of `completion-styles' to use for that category. | 844 | - `styles': the list of `completion-styles' to use for that category. |
| 835 | - `cycle': the `completion-cycle-threshold' to use for that category. | 845 | - `cycle': the `completion-cycle-threshold' to use for that category. |
| 836 | Categories are symbols such as `buffer' and `file', used when | 846 | Categories are symbols such as `buffer' and `file', used when |
| 837 | completing buffer and file names, respectively." | 847 | completing buffer and file names, respectively. |
| 838 | :version "24.1" | 848 | This overrides the defaults specified in `completion-category-defaults'." |
| 849 | :version "25.1" | ||
| 839 | :type `(alist :key-type (choice :tag "Category" | 850 | :type `(alist :key-type (choice :tag "Category" |
| 840 | (const buffer) | 851 | (const buffer) |
| 841 | (const file) | 852 | (const file) |
| @@ -851,9 +862,13 @@ completing buffer and file names, respectively." | |||
| 851 | (const :tag "Select one value from the menu." cycle) | 862 | (const :tag "Select one value from the menu." cycle) |
| 852 | ,completion--cycling-threshold-type)))) | 863 | ,completion--cycling-threshold-type)))) |
| 853 | 864 | ||
| 865 | (defun completion--category-override (category tag) | ||
| 866 | (or (assq tag (cdr (assq category completion-category-overrides))) | ||
| 867 | (assq tag (cdr (assq category completion-category-defaults))))) | ||
| 868 | |||
| 854 | (defun completion--styles (metadata) | 869 | (defun completion--styles (metadata) |
| 855 | (let* ((cat (completion-metadata-get metadata 'category)) | 870 | (let* ((cat (completion-metadata-get metadata 'category)) |
| 856 | (over (assq 'styles (cdr (assq cat completion-category-overrides))))) | 871 | (over (completion--category-override cat 'styles))) |
| 857 | (if over | 872 | (if over |
| 858 | (delete-dups (append (cdr over) (copy-sequence completion-styles))) | 873 | (delete-dups (append (cdr over) (copy-sequence completion-styles))) |
| 859 | completion-styles))) | 874 | completion-styles))) |
| @@ -967,7 +982,7 @@ completion candidates than this number." | |||
| 967 | 982 | ||
| 968 | (defun completion--cycle-threshold (metadata) | 983 | (defun completion--cycle-threshold (metadata) |
| 969 | (let* ((cat (completion-metadata-get metadata 'category)) | 984 | (let* ((cat (completion-metadata-get metadata 'category)) |
| 970 | (over (assq 'cycle (cdr (assq cat completion-category-overrides))))) | 985 | (over (completion--category-override cat 'cycle))) |
| 971 | (if over (cdr over) completion-cycle-threshold))) | 986 | (if over (cdr over) completion-cycle-threshold))) |
| 972 | 987 | ||
| 973 | (defvar-local completion-all-sorted-completions nil) | 988 | (defvar-local completion-all-sorted-completions nil) |
diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 2ce95d97ff8..6a6da17d1ce 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el | |||
| @@ -255,14 +255,18 @@ word(s) will be searched for via `eww-search-prefix'." | |||
| 255 | ((string-match-p "\\`ftp://" url) | 255 | ((string-match-p "\\`ftp://" url) |
| 256 | (user-error "FTP is not supported.")) | 256 | (user-error "FTP is not supported.")) |
| 257 | (t | 257 | (t |
| 258 | (if (and (= (length (split-string url)) 1) | 258 | (if (or (string-match "\\`https?:" url) |
| 259 | (or (and (not (string-match-p "\\`[\"\'].*[\"\']\\'" url)) | 259 | ;; Also try to match "naked" URLs like |
| 260 | (> (length (split-string url "[.:]")) 1)) | 260 | ;; en.wikipedia.org/wiki/Free software |
| 261 | (string-match eww-local-regex url))) | 261 | (string-match "\\`[A-Za-z_]+\\.[A-Za-z._]+/" url) |
| 262 | (and (= (length (split-string url)) 1) | ||
| 263 | (or (and (not (string-match-p "\\`[\"\'].*[\"\']\\'" url)) | ||
| 264 | (> (length (split-string url "[.:]")) 1)) | ||
| 265 | (string-match eww-local-regex url)))) | ||
| 262 | (progn | 266 | (progn |
| 263 | (unless (string-match-p "\\`[a-zA-Z][-a-zA-Z0-9+.]*://" url) | 267 | (unless (string-match-p "\\`[a-zA-Z][-a-zA-Z0-9+.]*://" url) |
| 264 | (setq url (concat "http://" url))) | 268 | (setq url (concat "http://" url))) |
| 265 | ;; some site don't redirect final / | 269 | ;; Some sites do not redirect final / |
| 266 | (when (string= (url-filename (url-generic-parse-url url)) "") | 270 | (when (string= (url-filename (url-generic-parse-url url)) "") |
| 267 | (setq url (concat url "/")))) | 271 | (setq url (concat url "/")))) |
| 268 | (setq url (concat eww-search-prefix | 272 | (setq url (concat eww-search-prefix |
| @@ -273,6 +277,7 @@ word(s) will be searched for via `eww-search-prefix'." | |||
| 273 | (eww-save-history)) | 277 | (eww-save-history)) |
| 274 | (eww-setup-buffer) | 278 | (eww-setup-buffer) |
| 275 | (plist-put eww-data :url url) | 279 | (plist-put eww-data :url url) |
| 280 | (plist-put eww-data :title "") | ||
| 276 | (eww-update-header-line-format) | 281 | (eww-update-header-line-format) |
| 277 | (let ((inhibit-read-only t)) | 282 | (let ((inhibit-read-only t)) |
| 278 | (insert (format "Loading %s..." url)) | 283 | (insert (format "Loading %s..." url)) |
diff --git a/lisp/net/shr.el b/lisp/net/shr.el index ed824cf3fb2..feb934c7190 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el | |||
| @@ -894,7 +894,12 @@ START, and END. Note that START and END should be markers." | |||
| 894 | (add-text-properties | 894 | (add-text-properties |
| 895 | start (point) | 895 | start (point) |
| 896 | (list 'shr-url url | 896 | (list 'shr-url url |
| 897 | 'help-echo (if title (shr-fold-text (format "%s (%s)" url title)) url) | 897 | 'help-echo (let ((iri (or (ignore-errors |
| 898 | (decode-coding-string | ||
| 899 | (url-unhex-string url) | ||
| 900 | 'utf-8 t)) | ||
| 901 | url))) | ||
| 902 | (if title (format "%s (%s)" iri title) iri)) | ||
| 898 | 'follow-link t | 903 | 'follow-link t |
| 899 | 'mouse-face 'highlight | 904 | 'mouse-face 'highlight |
| 900 | 'keymap shr-map))) | 905 | 'keymap shr-map))) |
diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index de6a33988a4..c25e52cdc6a 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el | |||
| @@ -248,7 +248,7 @@ name as matched contains | |||
| 248 | 248 | ||
| 249 | (defconst js--function-heading-1-re | 249 | (defconst js--function-heading-1-re |
| 250 | (concat | 250 | (concat |
| 251 | "^\\s-*function\\s-+\\(" js--name-re "\\)") | 251 | "^\\s-*function\\(?:\\s-\\|\\*\\)+\\(" js--name-re "\\)") |
| 252 | "Regexp matching the start of a JavaScript function header. | 252 | "Regexp matching the start of a JavaScript function header. |
| 253 | Match group 1 is the name of the function.") | 253 | Match group 1 is the name of the function.") |
| 254 | 254 | ||
| @@ -796,6 +796,9 @@ determined. Otherwise, return nil." | |||
| 796 | (let ((name t)) | 796 | (let ((name t)) |
| 797 | (forward-word) | 797 | (forward-word) |
| 798 | (forward-comment most-positive-fixnum) | 798 | (forward-comment most-positive-fixnum) |
| 799 | (when (eq (char-after) ?*) | ||
| 800 | (forward-char) | ||
| 801 | (forward-comment most-positive-fixnum)) | ||
| 799 | (when (looking-at js--name-re) | 802 | (when (looking-at js--name-re) |
| 800 | (setq name (match-string-no-properties 0)) | 803 | (setq name (match-string-no-properties 0)) |
| 801 | (goto-char (match-end 0))) | 804 | (goto-char (match-end 0))) |
diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index 41b70c7eff2..b822619f783 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el | |||
| @@ -434,7 +434,8 @@ GROUP is a string for decoration purposes and XREF is an | |||
| 434 | (list 'xref-location location | 434 | (list 'xref-location location |
| 435 | 'face 'font-lock-keyword-face | 435 | 'face 'font-lock-keyword-face |
| 436 | 'mouse-face 'highlight | 436 | 'mouse-face 'highlight |
| 437 | 'keymap xref--button-map) | 437 | 'keymap xref--button-map |
| 438 | 'help-echo "mouse-2: display, RET or mouse-1: navigate") | ||
| 438 | description)) | 439 | description)) |
| 439 | (when (or more1 more2) | 440 | (when (or more1 more2) |
| 440 | (insert "\n"))))) | 441 | (insert "\n"))))) |
diff --git a/lisp/shell.el b/lisp/shell.el index 6e336eb1403..f71d1407a49 100644 --- a/lisp/shell.el +++ b/lisp/shell.el | |||
| @@ -309,13 +309,6 @@ for Shell mode only." | |||
| 309 | (const :tag "on" t)) | 309 | (const :tag "on" t)) |
| 310 | :group 'shell) | 310 | :group 'shell) |
| 311 | 311 | ||
| 312 | (defcustom shell-display-buffer-actions display-buffer-base-action | ||
| 313 | "The `display-buffer' actions for the `*shell*' buffer." | ||
| 314 | :type display-buffer--action-custom-type | ||
| 315 | :risky t | ||
| 316 | :version "25.1" | ||
| 317 | :group 'shell) | ||
| 318 | |||
| 319 | (defvar shell-dirstack nil | 312 | (defvar shell-dirstack nil |
| 320 | "List of directories saved by pushd in this buffer's shell. | 313 | "List of directories saved by pushd in this buffer's shell. |
| 321 | Thus, this does not include the shell's current directory.") | 314 | Thus, this does not include the shell's current directory.") |
| @@ -726,7 +719,7 @@ Otherwise, one argument `-i' is passed to the shell. | |||
| 726 | 719 | ||
| 727 | ;; The buffer's window must be correctly set when we call comint (so | 720 | ;; The buffer's window must be correctly set when we call comint (so |
| 728 | ;; that comint sets the COLUMNS env var properly). | 721 | ;; that comint sets the COLUMNS env var properly). |
| 729 | (pop-to-buffer buffer shell-display-buffer-actions) | 722 | (pop-to-buffer buffer) |
| 730 | (unless (comint-check-proc buffer) | 723 | (unless (comint-check-proc buffer) |
| 731 | (let* ((prog (or explicit-shell-file-name | 724 | (let* ((prog (or explicit-shell-file-name |
| 732 | (getenv "ESHELL") shell-file-name)) | 725 | (getenv "ESHELL") shell-file-name)) |
diff --git a/lisp/simple.el b/lisp/simple.el index e15291a345b..25293edf88f 100644 --- a/lisp/simple.el +++ b/lisp/simple.el | |||
| @@ -5604,14 +5604,22 @@ If NOERROR, don't signal an error if we can't move that many lines." | |||
| 5604 | (> (cdr temporary-goal-column) 0)) | 5604 | (> (cdr temporary-goal-column) 0)) |
| 5605 | (setq target-hscroll (cdr temporary-goal-column))) | 5605 | (setq target-hscroll (cdr temporary-goal-column))) |
| 5606 | ;; Otherwise, we should reset `temporary-goal-column'. | 5606 | ;; Otherwise, we should reset `temporary-goal-column'. |
| 5607 | (let ((posn (posn-at-point))) | 5607 | (let ((posn (posn-at-point)) |
| 5608 | x-pos) | ||
| 5608 | (cond | 5609 | (cond |
| 5609 | ;; Handle the `overflow-newline-into-fringe' case: | 5610 | ;; Handle the `overflow-newline-into-fringe' case: |
| 5610 | ((eq (nth 1 posn) 'right-fringe) | 5611 | ((eq (nth 1 posn) 'right-fringe) |
| 5611 | (setq temporary-goal-column (cons (- (window-width) 1) hscroll))) | 5612 | (setq temporary-goal-column (cons (- (window-width) 1) hscroll))) |
| 5612 | ((car (posn-x-y posn)) | 5613 | ((car (posn-x-y posn)) |
| 5614 | (setq x-pos (car (posn-x-y posn))) | ||
| 5615 | ;; In R2L lines, the X pixel coordinate is measured from the | ||
| 5616 | ;; left edge of the window, but columns are still counted | ||
| 5617 | ;; from the logical-order beginning of the line, i.e. from | ||
| 5618 | ;; the right edge in this case. We need to adjust for that. | ||
| 5619 | (if (eq (current-bidi-paragraph-direction) 'right-to-left) | ||
| 5620 | (setq x-pos (- (window-body-width nil t) 1 x-pos))) | ||
| 5613 | (setq temporary-goal-column | 5621 | (setq temporary-goal-column |
| 5614 | (cons (/ (float (car (posn-x-y posn))) | 5622 | (cons (/ (float x-pos) |
| 5615 | (frame-char-width)) | 5623 | (frame-char-width)) |
| 5616 | hscroll)))))) | 5624 | hscroll)))))) |
| 5617 | (if target-hscroll | 5625 | (if target-hscroll |
diff --git a/lisp/subr.el b/lisp/subr.el index 8237a5b8d22..05345853edc 100644 --- a/lisp/subr.el +++ b/lisp/subr.el | |||
| @@ -1312,6 +1312,7 @@ is converted into a string by expressing it in decimal." | |||
| 1312 | (make-obsolete-variable 'redisplay-end-trigger-functions 'jit-lock-register "23.1") | 1312 | (make-obsolete-variable 'redisplay-end-trigger-functions 'jit-lock-register "23.1") |
| 1313 | (make-obsolete-variable 'deferred-action-list 'post-command-hook "24.1") | 1313 | (make-obsolete-variable 'deferred-action-list 'post-command-hook "24.1") |
| 1314 | (make-obsolete-variable 'deferred-action-function 'post-command-hook "24.1") | 1314 | (make-obsolete-variable 'deferred-action-function 'post-command-hook "24.1") |
| 1315 | (make-obsolete-variable 'redisplay-dont-pause nil "24.5") | ||
| 1315 | (make-obsolete 'window-redisplay-end-trigger nil "23.1") | 1316 | (make-obsolete 'window-redisplay-end-trigger nil "23.1") |
| 1316 | (make-obsolete 'set-window-redisplay-end-trigger nil "23.1") | 1317 | (make-obsolete 'set-window-redisplay-end-trigger nil "23.1") |
| 1317 | 1318 | ||
diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index 3b1f6c7103c..7801f4f8ed9 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el | |||
| @@ -886,7 +886,7 @@ current, and kill the buffer that visits the link." | |||
| 886 | (define-key map "=" 'vc-diff) | 886 | (define-key map "=" 'vc-diff) |
| 887 | (define-key map "D" 'vc-root-diff) | 887 | (define-key map "D" 'vc-root-diff) |
| 888 | (define-key map "~" 'vc-revision-other-window) | 888 | (define-key map "~" 'vc-revision-other-window) |
| 889 | (define-key map "[delete]" 'vc-delete-file) | 889 | (define-key map "x" 'vc-delete-file) |
| 890 | map)) | 890 | map)) |
| 891 | (fset 'vc-prefix-map vc-prefix-map) | 891 | (fset 'vc-prefix-map vc-prefix-map) |
| 892 | (define-key ctl-x-map "v" 'vc-prefix-map) | 892 | (define-key ctl-x-map "v" 'vc-prefix-map) |