diff options
| author | Stefan Monnier | 2015-01-21 14:39:06 -0500 |
|---|---|---|
| committer | Stefan Monnier | 2015-01-21 14:39:06 -0500 |
| commit | 59e7fe6d0c6988687b53c279941c9ebb3f887eed (patch) | |
| tree | b5330cedb77c370aa00c5039a6c7c14fca6f5fe9 | |
| parent | 41efcf4db1589c2141ace6b9c3c15aa0386ecf95 (diff) | |
| download | emacs-59e7fe6d0c6988687b53c279941c9ebb3f887eed.tar.gz emacs-59e7fe6d0c6988687b53c279941c9ebb3f887eed.zip | |
* lisp/emacs-lisp/eieio*.el: Fix up warnings and improve compatibility
Fixes: debbugs:19645
* lisp/emacs-lisp/cl-generic.el (cl-defgeneric): Add support for `declare'.
(cl--generic-setf-rewrite): Setup the setf expander right away.
(cl-defmethod): Make sure the setf expander is setup before we expand
the body.
(cl-defmethod): Silence byte-compiler warnings.
(cl-generic-define-method): Shuffle code to change return value.
(cl--generic-method-info): New function, extracted from
cl--generic-describe.
(cl--generic-describe): Use it.
* lisp/emacs-lisp/eieio-speedbar.el:
* lisp/emacs-lisp/eieio-datadebug.el:
* lisp/emacs-lisp/eieio-custom.el:
* lisp/emacs-lisp/eieio-base.el: Use cl-defmethod.
* lisp/emacs-lisp/eieio-compat.el (eieio--defmethod): Avoid no-next-method
errors when there's a `before' but no `primary'.
(next-method-p): Return nil rather than signal an error.
(eieio-defgeneric): Remove bogus (fboundp 'method).
* lisp/emacs-lisp/eieio-opt.el: Adapt to cl-generic.
(eieio--specializers-apply-to-class-p): New function.
(eieio-all-generic-functions): Use it.
(eieio-method-documentation): Use it as well as cl--generic-method-info.
Change format of return value.
(eieio-help-class): Adapt accordingly.
* lisp/emacs-lisp/eieio.el: Use cl-defmethod.
(defclass): Generate cl-defmethod calls; use setf methods for :accessor.
(eieio-object-name-string): Declare as obsolete.
* test/automated/cl-generic-tests.el (setf cl--generic-2): Make sure
the setf can be used already in the body of the method.
| -rw-r--r-- | lisp/ChangeLog | 33 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-generic.el | 122 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-base.el | 36 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-compat.el | 33 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-custom.el | 12 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-datadebug.el | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-opt.el | 113 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-speedbar.el | 20 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio.el | 89 | ||||
| -rw-r--r-- | test/ChangeLog | 11 | ||||
| -rw-r--r-- | test/automated/cl-generic-tests.el | 5 | ||||
| -rw-r--r-- | test/automated/eieio-test-methodinvoke.el | 2 |
12 files changed, 275 insertions, 205 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 65c068425f9..d13bacfd965 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog | |||
| @@ -1,3 +1,36 @@ | |||
| 1 | 2015-01-21 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 2 | |||
| 3 | * emacs-lisp/eieio.el: Use cl-defmethod. | ||
| 4 | (defclass): Generate cl-defmethod calls; use setf methods for :accessor. | ||
| 5 | (eieio-object-name-string): Declare as obsolete. | ||
| 6 | |||
| 7 | * emacs-lisp/eieio-opt.el: Adapt to cl-generic. | ||
| 8 | (eieio--specializers-apply-to-class-p): New function. | ||
| 9 | (eieio-all-generic-functions): Use it. | ||
| 10 | (eieio-method-documentation): Use it as well as cl--generic-method-info. | ||
| 11 | Change format of return value. | ||
| 12 | (eieio-help-class): Adapt accordingly. | ||
| 13 | |||
| 14 | * emacs-lisp/eieio-compat.el (eieio--defmethod): Avoid no-next-method | ||
| 15 | errors when there's a `before' but no `primary' (bug#19645). | ||
| 16 | (next-method-p): Return nil rather than signal an error. | ||
| 17 | (eieio-defgeneric): Remove bogus (fboundp 'method). | ||
| 18 | |||
| 19 | * emacs-lisp/eieio-speedbar.el: | ||
| 20 | * emacs-lisp/eieio-datadebug.el: | ||
| 21 | * emacs-lisp/eieio-custom.el: | ||
| 22 | * emacs-lisp/eieio-base.el: Use cl-defmethod. | ||
| 23 | |||
| 24 | * emacs-lisp/cl-generic.el (cl-defgeneric): Add support for `declare'. | ||
| 25 | (cl--generic-setf-rewrite): Setup the setf expander right away. | ||
| 26 | (cl-defmethod): Make sure the setf expander is setup before we expand | ||
| 27 | the body. | ||
| 28 | (cl-defmethod): Silence byte-compiler warnings. | ||
| 29 | (cl-generic-define-method): Shuffle code to change return value. | ||
| 30 | (cl--generic-method-info): New function, extracted from | ||
| 31 | cl--generic-describe. | ||
| 32 | (cl--generic-describe): Use it. | ||
| 33 | |||
| 1 | 2015-01-21 Dmitry Gutov <dgutov@yandex.ru> | 34 | 2015-01-21 Dmitry Gutov <dgutov@yandex.ru> |
| 2 | 35 | ||
| 3 | * progmodes/xref.el (xref--xref-buffer-mode-map): Define before | 36 | * progmodes/xref.el (xref--xref-buffer-mode-map): Define before |
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 3bbddfc45a1..8dee9a38ab0 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el | |||
| @@ -98,19 +98,20 @@ They should be sorted from most specific to least specific.") | |||
| 98 | (:constructor cl--generic-make | 98 | (:constructor cl--generic-make |
| 99 | (name &optional dispatches method-table)) | 99 | (name &optional dispatches method-table)) |
| 100 | (:predicate nil)) | 100 | (:predicate nil)) |
| 101 | (name nil :read-only t) ;Pointer back to the symbol. | 101 | (name nil :type symbol :read-only t) ;Pointer back to the symbol. |
| 102 | ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index | 102 | ;; `dispatches' holds a list of (ARGNUM . TAGCODES) where ARGNUM is the index |
| 103 | ;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP) | 103 | ;; of the corresponding argument and TAGCODES is a list of (PRIORITY . EXP) |
| 104 | ;; where the EXPs are expressions (to be `or'd together) to compute the tag | 104 | ;; where the EXPs are expressions (to be `or'd together) to compute the tag |
| 105 | ;; on which to dispatch and PRIORITY is the priority of each expression to | 105 | ;; on which to dispatch and PRIORITY is the priority of each expression to |
| 106 | ;; decide in which order to sort them. | 106 | ;; decide in which order to sort them. |
| 107 | ;; The most important dispatch is last in the list (and the least is first). | 107 | ;; The most important dispatch is last in the list (and the least is first). |
| 108 | dispatches | 108 | (dispatches nil :type (list-of (cons natnum (list-of tagcode)))) |
| 109 | ;; `method-table' is a list of | 109 | ;; `method-table' is a list of |
| 110 | ;; ((SPECIALIZERS . QUALIFIER) USES-CNM . FUNCTION), where | 110 | ;; ((SPECIALIZERS . QUALIFIER) USES-CNM . FUNCTION), where |
| 111 | ;; USES-CNM is a boolean indicating if FUNCTION calls `cl-call-next-method' | 111 | ;; USES-CNM is a boolean indicating if FUNCTION calls `cl-call-next-method' |
| 112 | ;; (and hence expects an extra argument holding the next-method). | 112 | ;; (and hence expects an extra argument holding the next-method). |
| 113 | method-table) | 113 | (method-table nil :type (list-of (cons (cons (list-of type) keyword) |
| 114 | (cons boolean function))))) | ||
| 114 | 115 | ||
| 115 | (defmacro cl--generic (name) | 116 | (defmacro cl--generic (name) |
| 116 | `(get ,name 'cl--generic)) | 117 | `(get ,name 'cl--generic)) |
| @@ -134,15 +135,16 @@ They should be sorted from most specific to least specific.") | |||
| 134 | generic)) | 135 | generic)) |
| 135 | 136 | ||
| 136 | (defun cl--generic-setf-rewrite (name) | 137 | (defun cl--generic-setf-rewrite (name) |
| 137 | (let ((setter (intern (format "cl-generic-setter--%s" name)))) | 138 | (let* ((setter (intern (format "cl-generic-setter--%s" name))) |
| 138 | (cons setter | 139 | (exp `(unless (eq ',setter (get ',name 'cl-generic-setter)) |
| 139 | `(eval-and-compile | 140 | ;; (when (get ',name 'gv-expander) |
| 140 | (unless (eq ',setter (get ',name 'cl-generic-setter)) | 141 | ;; (error "gv-expander conflicts with (setf %S)" ',name)) |
| 141 | ;; (when (get ',name 'gv-expander) | 142 | (setf (get ',name 'cl-generic-setter) ',setter) |
| 142 | ;; (error "gv-expander conflicts with (setf %S)" ',name)) | 143 | (gv-define-setter ,name (val &rest args) |
| 143 | (setf (get ',name 'cl-generic-setter) ',setter) | 144 | (cons ',setter (cons val args)))))) |
| 144 | (gv-define-setter ,name (val &rest args) | 145 | ;; Make sure `setf' can be used right away, e.g. in the body of the method. |
| 145 | (cons ',setter (cons val args)))))))) | 146 | (eval exp t) |
| 147 | (cons setter exp))) | ||
| 146 | 148 | ||
| 147 | ;;;###autoload | 149 | ;;;###autoload |
| 148 | (defmacro cl-defgeneric (name args &rest options-and-methods) | 150 | (defmacro cl-defgeneric (name args &rest options-and-methods) |
| @@ -151,8 +153,9 @@ DOC-STRING is the base documentation for this class. A generic | |||
| 151 | function has no body, as its purpose is to decide which method body | 153 | function has no body, as its purpose is to decide which method body |
| 152 | is appropriate to use. Specific methods are defined with `cl-defmethod'. | 154 | is appropriate to use. Specific methods are defined with `cl-defmethod'. |
| 153 | With this implementation the ARGS are currently ignored. | 155 | With this implementation the ARGS are currently ignored. |
| 154 | OPTIONS-AND-METHODS is currently only used to specify the docstring, | 156 | OPTIONS-AND-METHODS currently understands: |
| 155 | via (:documentation DOCSTRING)." | 157 | - (:documentation DOCSTRING) |
| 158 | - (declare DECLARATIONS)" | ||
| 156 | (declare (indent 2) (doc-string 3)) | 159 | (declare (indent 2) (doc-string 3)) |
| 157 | (let* ((docprop (assq :documentation options-and-methods)) | 160 | (let* ((docprop (assq :documentation options-and-methods)) |
| 158 | (doc (cond ((stringp (car-safe options-and-methods)) | 161 | (doc (cond ((stringp (car-safe options-and-methods)) |
| @@ -161,13 +164,26 @@ via (:documentation DOCSTRING)." | |||
| 161 | (prog1 | 164 | (prog1 |
| 162 | (cadr docprop) | 165 | (cadr docprop) |
| 163 | (setq options-and-methods | 166 | (setq options-and-methods |
| 164 | (delq docprop options-and-methods))))))) | 167 | (delq docprop options-and-methods)))))) |
| 168 | (declarations (assq 'declare options-and-methods))) | ||
| 169 | (when declarations | ||
| 170 | (setq options-and-methods | ||
| 171 | (delq declarations options-and-methods))) | ||
| 165 | `(progn | 172 | `(progn |
| 166 | ,(when (eq 'setf (car-safe name)) | 173 | ,(when (eq 'setf (car-safe name)) |
| 167 | (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite | 174 | (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite |
| 168 | (cadr name)))) | 175 | (cadr name)))) |
| 169 | (setq name setter) | 176 | (setq name setter) |
| 170 | code)) | 177 | code)) |
| 178 | ,@(mapcar (lambda (declaration) | ||
| 179 | (let ((f (cdr (assq (car declaration) | ||
| 180 | defun-declarations-alist)))) | ||
| 181 | (cond | ||
| 182 | (f (apply (car f) name args (cdr declaration))) | ||
| 183 | (t (message "Warning: Unknown defun property `%S' in %S" | ||
| 184 | (car declaration) name) | ||
| 185 | nil)))) | ||
| 186 | (cdr declarations)) | ||
| 171 | (defalias ',name | 187 | (defalias ',name |
| 172 | (cl-generic-define ',name ',args ',options-and-methods) | 188 | (cl-generic-define ',name ',args ',options-and-methods) |
| 173 | ,(help-add-fundoc-usage doc args))))) | 189 | ,(help-add-fundoc-usage doc args))))) |
| @@ -292,18 +308,19 @@ which case this method will be invoked when the argument is `eql' to VAL. | |||
| 292 | list ; arguments | 308 | list ; arguments |
| 293 | [ &optional stringp ] ; documentation string | 309 | [ &optional stringp ] ; documentation string |
| 294 | def-body))) ; part to be debugged | 310 | def-body))) ; part to be debugged |
| 295 | (let ((qualifiers nil)) | 311 | (let ((qualifiers nil) |
| 312 | (setfizer (if (eq 'setf (car-safe name)) | ||
| 313 | ;; Call it before we call cl--generic-lambda. | ||
| 314 | (cl--generic-setf-rewrite (cadr name))))) | ||
| 296 | (while (keywordp args) | 315 | (while (keywordp args) |
| 297 | (push args qualifiers) | 316 | (push args qualifiers) |
| 298 | (setq args (pop body))) | 317 | (setq args (pop body))) |
| 299 | (pcase-let* ((with-cnm (not (memq (car qualifiers) '(:before :after)))) | 318 | (pcase-let* ((with-cnm (not (memq (car qualifiers) '(:before :after)))) |
| 300 | (`(,uses-cnm . ,fun) (cl--generic-lambda args body with-cnm))) | 319 | (`(,uses-cnm . ,fun) (cl--generic-lambda args body with-cnm))) |
| 301 | `(progn | 320 | `(progn |
| 302 | ,(when (eq 'setf (car-safe name)) | 321 | ,(when setfizer |
| 303 | (pcase-let ((`(,setter . ,code) (cl--generic-setf-rewrite | 322 | (setq name (car setfizer)) |
| 304 | (cadr name)))) | 323 | (cdr setfizer)) |
| 305 | (setq name setter) | ||
| 306 | code)) | ||
| 307 | ,(and (get name 'byte-obsolete-info) | 324 | ,(and (get name 'byte-obsolete-info) |
| 308 | (or (not (fboundp 'byte-compile-warning-enabled-p)) | 325 | (or (not (fboundp 'byte-compile-warning-enabled-p)) |
| 309 | (byte-compile-warning-enabled-p 'obsolete)) | 326 | (byte-compile-warning-enabled-p 'obsolete)) |
| @@ -311,6 +328,11 @@ which case this method will be invoked when the argument is `eql' to VAL. | |||
| 311 | (macroexp--warn-and-return | 328 | (macroexp--warn-and-return |
| 312 | (macroexp--obsolete-warning name obsolete "generic function") | 329 | (macroexp--obsolete-warning name obsolete "generic function") |
| 313 | nil))) | 330 | nil))) |
| 331 | ;; You could argue that `defmethod' modifies rather than defines the | ||
| 332 | ;; function, so warnings like "not known to be defined" are fair game. | ||
| 333 | ;; But in practice, it's common to use `cl-defmethod' | ||
| 334 | ;; without a previous `cl-defgeneric'. | ||
| 335 | (declare-function ,name "") | ||
| 314 | (cl-generic-define-method ',name ',qualifiers ',args | 336 | (cl-generic-define-method ',name ',qualifiers ',args |
| 315 | ,uses-cnm ,fun))))) | 337 | ,uses-cnm ,fun))))) |
| 316 | 338 | ||
| @@ -344,14 +366,14 @@ which case this method will be invoked when the argument is `eql' to VAL. | |||
| 344 | (if me (setcdr me (cons uses-cnm function)) | 366 | (if me (setcdr me (cons uses-cnm function)) |
| 345 | (setf (cl--generic-method-table generic) | 367 | (setf (cl--generic-method-table generic) |
| 346 | (cons `(,key ,uses-cnm . ,function) mt))) | 368 | (cons `(,key ,uses-cnm . ,function) mt))) |
| 347 | ;; For aliases, cl--generic-name gives us the actual name. | 369 | (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers)) |
| 370 | current-load-list :test #'equal) | ||
| 348 | (let ((gfun (cl--generic-make-function generic)) | 371 | (let ((gfun (cl--generic-make-function generic)) |
| 349 | ;; Prevent `defalias' from recording this as the definition site of | 372 | ;; Prevent `defalias' from recording this as the definition site of |
| 350 | ;; the generic function. | 373 | ;; the generic function. |
| 351 | current-load-list) | 374 | current-load-list) |
| 352 | (defalias (cl--generic-name generic) gfun)) | 375 | ;; For aliases, cl--generic-name gives us the actual name. |
| 353 | (cl-pushnew `(cl-defmethod . (,(cl--generic-name generic) . ,specializers)) | 376 | (defalias (cl--generic-name generic) gfun)))) |
| 354 | current-load-list :test #'equal))) | ||
| 355 | 377 | ||
| 356 | (defmacro cl--generic-with-memoization (place &rest code) | 378 | (defmacro cl--generic-with-memoization (place &rest code) |
| 357 | (declare (indent 1) (debug t)) | 379 | (declare (indent 1) (debug t)) |
| @@ -448,8 +470,12 @@ for all those different tags in the method-cache.") | |||
| 448 | ;; We don't currently have "method objects" like CLOS | 470 | ;; We don't currently have "method objects" like CLOS |
| 449 | ;; does so we can't really do it the CLOS way. | 471 | ;; does so we can't really do it the CLOS way. |
| 450 | ;; The closest would be to pass the lambda corresponding | 472 | ;; The closest would be to pass the lambda corresponding |
| 451 | ;; to the method, but the caller wouldn't be able to do | 473 | ;; to the method, or maybe the ((SPECIALIZERS |
| 452 | ;; much with it anyway. So we pass nil for now. | 474 | ;; . QUALIFIER) USE-CNM . FUNCTION) entry from the method |
| 475 | ;; table, but the caller wouldn't be able to do much with | ||
| 476 | ;; it anyway. So we pass nil for now. | ||
| 477 | ;; FIXME: signal `no-primary-method' if there's | ||
| 478 | ;; no primary. | ||
| 453 | (apply #'cl-no-next-method generic-name nil args))) | 479 | (apply #'cl-no-next-method generic-name nil args))) |
| 454 | ;; We use `cdr' to drop the `uses-cnm' annotations. | 480 | ;; We use `cdr' to drop the `uses-cnm' annotations. |
| 455 | (before | 481 | (before |
| @@ -566,6 +592,24 @@ Can only be used from within the lexical body of a primary or around method." | |||
| 566 | (add-to-list 'find-function-regexp-alist | 592 | (add-to-list 'find-function-regexp-alist |
| 567 | `(cl-defmethod . ,#'cl--generic-search-method))) | 593 | `(cl-defmethod . ,#'cl--generic-search-method))) |
| 568 | 594 | ||
| 595 | (defun cl--generic-method-info (method) | ||
| 596 | (pcase-let ((`((,specializers . ,qualifier) ,uses-cnm . ,function) method)) | ||
| 597 | (let* ((args (help-function-arglist function 'names)) | ||
| 598 | (docstring (documentation function)) | ||
| 599 | (doconly (if docstring | ||
| 600 | (let ((split (help-split-fundoc docstring nil))) | ||
| 601 | (if split (cdr split) docstring)))) | ||
| 602 | (combined-args ())) | ||
| 603 | (if uses-cnm (setq args (cdr args))) | ||
| 604 | (dolist (specializer specializers) | ||
| 605 | (let ((arg (if (eq '&rest (car args)) | ||
| 606 | (intern (format "arg%d" (length combined-args))) | ||
| 607 | (pop args)))) | ||
| 608 | (push (if (eq specializer t) arg (list arg specializer)) | ||
| 609 | combined-args))) | ||
| 610 | (setq combined-args (append (nreverse combined-args) args)) | ||
| 611 | (list qualifier combined-args doconly)))) | ||
| 612 | |||
| 569 | (add-hook 'help-fns-describe-function-functions #'cl--generic-describe) | 613 | (add-hook 'help-fns-describe-function-functions #'cl--generic-describe) |
| 570 | (defun cl--generic-describe (function) | 614 | (defun cl--generic-describe (function) |
| 571 | (let ((generic (if (symbolp function) (cl--generic function)))) | 615 | (let ((generic (if (symbolp function) (cl--generic function)))) |
| @@ -575,25 +619,11 @@ Can only be used from within the lexical body of a primary or around method." | |||
| 575 | (insert "\n\nThis is a generic function.\n\n") | 619 | (insert "\n\nThis is a generic function.\n\n") |
| 576 | (insert (propertize "Implementations:\n\n" 'face 'bold)) | 620 | (insert (propertize "Implementations:\n\n" 'face 'bold)) |
| 577 | ;; Loop over fanciful generics | 621 | ;; Loop over fanciful generics |
| 578 | (pcase-dolist (`((,specializers . ,qualifier) ,uses-cnm . ,method) | 622 | (dolist (method (cl--generic-method-table generic)) |
| 579 | (cl--generic-method-table generic)) | 623 | (let* ((info (cl--generic-method-info method))) |
| 580 | (let* ((args (help-function-arglist method 'names)) | ||
| 581 | (docstring (documentation method)) | ||
| 582 | (doconly (if docstring | ||
| 583 | (let ((split (help-split-fundoc docstring nil))) | ||
| 584 | (if split (cdr split) docstring)))) | ||
| 585 | (combined-args ())) | ||
| 586 | (if uses-cnm (setq args (cdr args))) | ||
| 587 | (dolist (specializer specializers) | ||
| 588 | (let ((arg (if (eq '&rest (car args)) | ||
| 589 | (intern (format "arg%d" (length combined-args))) | ||
| 590 | (pop args)))) | ||
| 591 | (push (if (eq specializer t) arg (list arg specializer)) | ||
| 592 | combined-args))) | ||
| 593 | (setq combined-args (append (nreverse combined-args) args)) | ||
| 594 | ;; FIXME: Add hyperlinks for the types as well. | 624 | ;; FIXME: Add hyperlinks for the types as well. |
| 595 | (insert (format "%S %S" qualifier combined-args)) | 625 | (insert (format "%S %S" (nth 0 info) (nth 1 info))) |
| 596 | (let* ((met-name (cons function specializers)) | 626 | (let* ((met-name (cons function (caar method))) |
| 597 | (file (find-lisp-object-file-name met-name 'cl-defmethod))) | 627 | (file (find-lisp-object-file-name met-name 'cl-defmethod))) |
| 598 | (when file | 628 | (when file |
| 599 | (insert " in `") | 629 | (insert " in `") |
| @@ -601,7 +631,7 @@ Can only be used from within the lexical body of a primary or around method." | |||
| 601 | 'help-function-def met-name file | 631 | 'help-function-def met-name file |
| 602 | 'cl-defmethod) | 632 | 'cl-defmethod) |
| 603 | (insert "'.\n"))) | 633 | (insert "'.\n"))) |
| 604 | (insert "\n" (or doconly "Undocumented") "\n\n"))))))) | 634 | (insert "\n" (or (nth 2 info) "Undocumented") "\n\n"))))))) |
| 605 | 635 | ||
| 606 | ;;; Support for (eql <val>) specializers. | 636 | ;;; Support for (eql <val>) specializers. |
| 607 | 637 | ||
diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 9931fbd114e..feb06711cb3 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el | |||
| @@ -52,7 +52,7 @@ a parent instance. When a slot in the child is referenced, and has | |||
| 52 | not been set, use values from the parent." | 52 | not been set, use values from the parent." |
| 53 | :abstract t) | 53 | :abstract t) |
| 54 | 54 | ||
| 55 | (defmethod slot-unbound ((object eieio-instance-inheritor) | 55 | (cl-defmethod slot-unbound ((object eieio-instance-inheritor) |
| 56 | _class slot-name _fn) | 56 | _class slot-name _fn) |
| 57 | "If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal. | 57 | "If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal. |
| 58 | SLOT-NAME is the offending slot. FN is the function signaling the error." | 58 | SLOT-NAME is the offending slot. FN is the function signaling the error." |
| @@ -61,16 +61,16 @@ SLOT-NAME is the offending slot. FN is the function signaling the error." | |||
| 61 | ;; method if the parent instance's slot is unbound. | 61 | ;; method if the parent instance's slot is unbound. |
| 62 | (eieio-oref (oref object parent-instance) slot-name) | 62 | (eieio-oref (oref object parent-instance) slot-name) |
| 63 | ;; Throw the regular signal. | 63 | ;; Throw the regular signal. |
| 64 | (call-next-method))) | 64 | (cl-call-next-method))) |
| 65 | 65 | ||
| 66 | (defmethod clone ((obj eieio-instance-inheritor) &rest _params) | 66 | (cl-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 (call-next-method))) | 69 | (let ((nobj (cl-call-next-method))) |
| 70 | (oset nobj parent-instance obj) | 70 | (oset nobj parent-instance obj) |
| 71 | nobj)) | 71 | nobj)) |
| 72 | 72 | ||
| 73 | (defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor) | 73 | (cl-defmethod eieio-instance-inheritor-slot-boundp ((object eieio-instance-inheritor) |
| 74 | slot) | 74 | slot) |
| 75 | "Return non-nil if the instance inheritor OBJECT's SLOT is bound. | 75 | "Return non-nil if the instance inheritor OBJECT's SLOT is bound. |
| 76 | See `slot-boundp' for details on binding slots. | 76 | See `slot-boundp' for details on binding slots. |
| @@ -103,7 +103,7 @@ Inheritors from this class must overload `tracking-symbol' which is | |||
| 103 | a variable symbol used to store a list of all instances." | 103 | a variable symbol used to store a list of all instances." |
| 104 | :abstract t) | 104 | :abstract t) |
| 105 | 105 | ||
| 106 | (defmethod initialize-instance :AFTER ((this eieio-instance-tracker) | 106 | (cl-defmethod initialize-instance :after ((this eieio-instance-tracker) |
| 107 | &rest _slots) | 107 | &rest _slots) |
| 108 | "Make sure THIS is in our master list of this class. | 108 | "Make sure THIS is in our master list of this class. |
| 109 | Optional argument SLOTS are the initialization arguments." | 109 | Optional argument SLOTS are the initialization arguments." |
| @@ -112,7 +112,7 @@ Optional argument SLOTS are the initialization arguments." | |||
| 112 | (if (not (memq this (symbol-value sym))) | 112 | (if (not (memq this (symbol-value sym))) |
| 113 | (set sym (append (symbol-value sym) (list this)))))) | 113 | (set sym (append (symbol-value sym) (list this)))))) |
| 114 | 114 | ||
| 115 | (defmethod delete-instance ((this eieio-instance-tracker)) | 115 | (cl-defmethod delete-instance ((this eieio-instance-tracker)) |
| 116 | "Remove THIS from the master list of this class." | 116 | "Remove THIS from the master list of this class." |
| 117 | (set (oref this tracking-symbol) | 117 | (set (oref this tracking-symbol) |
| 118 | (delq this (symbol-value (oref this tracking-symbol))))) | 118 | (delq this (symbol-value (oref this tracking-symbol))))) |
| @@ -140,7 +140,7 @@ Multiple calls to `make-instance' will return this object.")) | |||
| 140 | 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." |
| 141 | :abstract t) | 141 | :abstract t) |
| 142 | 142 | ||
| 143 | (defmethod eieio-constructor :STATIC ((class eieio-singleton) &rest _slots) | 143 | (cl-defmethod eieio-constructor ((class (subclass eieio-singleton)) &rest _slots) |
| 144 | "Constructor for singleton CLASS. | 144 | "Constructor for singleton CLASS. |
| 145 | NAME and SLOTS initialize the new object. | 145 | NAME and SLOTS initialize the new object. |
| 146 | This constructor guarantees that no matter how many you request, | 146 | This constructor guarantees that no matter how many you request, |
| @@ -149,7 +149,7 @@ only one object ever exists." | |||
| 149 | ;; with class allocated slots or default values. | 149 | ;; with class allocated slots or default values. |
| 150 | (let ((old (oref-default class singleton))) | 150 | (let ((old (oref-default class singleton))) |
| 151 | (if (eq old eieio-unbound) | 151 | (if (eq old eieio-unbound) |
| 152 | (oset-default class singleton (call-next-method)) | 152 | (oset-default class singleton (cl-call-next-method)) |
| 153 | old))) | 153 | old))) |
| 154 | 154 | ||
| 155 | 155 | ||
| @@ -198,7 +198,7 @@ object. For this reason, only slots which do not have an `:initarg' | |||
| 198 | specified will not be saved." | 198 | specified will not be saved." |
| 199 | :abstract t) | 199 | :abstract t) |
| 200 | 200 | ||
| 201 | (defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt | 201 | (cl-defmethod eieio-persistent-save-interactive ((this eieio-persistent) prompt |
| 202 | &optional name) | 202 | &optional name) |
| 203 | "Prepare to save THIS. Use in an `interactive' statement. | 203 | "Prepare to save THIS. Use in an `interactive' statement. |
| 204 | Query user for file name with PROMPT if THIS does not yet specify | 204 | Query user for file name with PROMPT if THIS does not yet specify |
| @@ -417,17 +417,17 @@ If no class is referenced there, then return nil." | |||
| 417 | ;; No match, not a class. | 417 | ;; No match, not a class. |
| 418 | nil))) | 418 | nil))) |
| 419 | 419 | ||
| 420 | (defmethod object-write ((this eieio-persistent) &optional comment) | 420 | (cl-defmethod object-write ((this eieio-persistent) &optional comment) |
| 421 | "Write persistent object THIS out to the current stream. | 421 | "Write persistent object THIS out to the current stream. |
| 422 | Optional argument COMMENT is a header line comment." | 422 | Optional argument COMMENT is a header line comment." |
| 423 | (call-next-method this (or comment (oref this file-header-line)))) | 423 | (cl-call-next-method this (or comment (oref this file-header-line)))) |
| 424 | 424 | ||
| 425 | (defmethod eieio-persistent-path-relative ((this eieio-persistent) file) | 425 | (cl-defmethod eieio-persistent-path-relative ((this eieio-persistent) file) |
| 426 | "For object THIS, make absolute file name FILE relative." | 426 | "For object THIS, make absolute file name FILE relative." |
| 427 | (file-relative-name (expand-file-name file) | 427 | (file-relative-name (expand-file-name file) |
| 428 | (file-name-directory (oref this file)))) | 428 | (file-name-directory (oref this file)))) |
| 429 | 429 | ||
| 430 | (defmethod eieio-persistent-save ((this eieio-persistent) &optional file) | 430 | (cl-defmethod eieio-persistent-save ((this eieio-persistent) &optional file) |
| 431 | "Save persistent object THIS to disk. | 431 | "Save persistent object THIS to disk. |
| 432 | Optional argument FILE overrides the file name specified in the object | 432 | Optional argument FILE overrides the file name specified in the object |
| 433 | instance." | 433 | instance." |
| @@ -474,21 +474,21 @@ instance." | |||
| 474 | "Object with a name." | 474 | "Object with a name." |
| 475 | :abstract t) | 475 | :abstract t) |
| 476 | 476 | ||
| 477 | (defmethod eieio-object-name-string ((obj eieio-named)) | 477 | (cl-defmethod eieio-object-name-string ((obj eieio-named)) |
| 478 | "Return a string which is OBJ's name." | 478 | "Return a string which is OBJ's name." |
| 479 | (or (slot-value obj 'object-name) | 479 | (or (slot-value obj 'object-name) |
| 480 | (symbol-name (eieio-object-class obj)))) | 480 | (symbol-name (eieio-object-class obj)))) |
| 481 | 481 | ||
| 482 | (defmethod eieio-object-set-name-string ((obj eieio-named) name) | 482 | (cl-defmethod eieio-object-set-name-string ((obj eieio-named) name) |
| 483 | "Set the string which is OBJ's NAME." | 483 | "Set the string which is OBJ's NAME." |
| 484 | (eieio--check-type stringp name) | 484 | (eieio--check-type stringp name) |
| 485 | (eieio-oset obj 'object-name name)) | 485 | (eieio-oset obj 'object-name name)) |
| 486 | 486 | ||
| 487 | (defmethod clone ((obj eieio-named) &rest params) | 487 | (cl-defmethod clone ((obj eieio-named) &rest params) |
| 488 | "Clone OBJ, initializing `:parent' to OBJ. | 488 | "Clone OBJ, initializing `:parent' to OBJ. |
| 489 | All slots are unbound, except those initialized with PARAMS." | 489 | All slots are unbound, except those initialized with PARAMS." |
| 490 | (let* ((newname (and (stringp (car params)) (pop params))) | 490 | (let* ((newname (and (stringp (car params)) (pop params))) |
| 491 | (nobj (apply #'call-next-method obj params)) | 491 | (nobj (apply #'cl-call-next-method obj params)) |
| 492 | (nm (slot-value obj 'object-name))) | 492 | (nm (slot-value obj 'object-name))) |
| 493 | (eieio-oset obj 'object-name | 493 | (eieio-oset obj 'object-name |
| 494 | (or newname | 494 | (or newname |
diff --git a/lisp/emacs-lisp/eieio-compat.el b/lisp/emacs-lisp/eieio-compat.el index 34c06c01763..c2dabf7f446 100644 --- a/lisp/emacs-lisp/eieio-compat.el +++ b/lisp/emacs-lisp/eieio-compat.el | |||
| @@ -190,13 +190,27 @@ Summary: | |||
| 190 | (if split (cdr split) docstring)))) | 190 | (if split (cdr split) docstring)))) |
| 191 | (new-docstring (help-add-fundoc-usage doc-only | 191 | (new-docstring (help-add-fundoc-usage doc-only |
| 192 | (cons 'cl-cnm args)))) | 192 | (cons 'cl-cnm args)))) |
| 193 | ;; FIXME: ¡Add the new-docstring to those closures! | 193 | ;; FIXME: ¡Add new-docstring to those closures! |
| 194 | (lambda (cnm &rest args) | 194 | (lambda (cnm &rest args) |
| 195 | (cl-letf (((symbol-function 'call-next-method) cnm) | 195 | (cl-letf (((symbol-function 'call-next-method) cnm) |
| 196 | ((symbol-function 'next-method-p) | 196 | ((symbol-function 'next-method-p) |
| 197 | (lambda () (cl--generic-isnot-nnm-p cnm)))) | 197 | (lambda () (cl--generic-isnot-nnm-p cnm)))) |
| 198 | (apply code args)))) | 198 | (apply code args)))) |
| 199 | code)))) | 199 | code)) |
| 200 | ;; The old EIEIO code did not signal an error when there are methods | ||
| 201 | ;; applicable but only of the before/after kind. So if we add a :before | ||
| 202 | ;; or :after, make sure there's a matching dummy primary. | ||
| 203 | (when (and (memq kind '(:before :after)) | ||
| 204 | (not (assoc (cons (mapcar (lambda (arg) | ||
| 205 | (if (consp arg) (nth 1 arg) t)) | ||
| 206 | specializers) | ||
| 207 | :primary) | ||
| 208 | (cl--generic-method-table (cl--generic method))))) | ||
| 209 | (cl-generic-define-method method () specializers t | ||
| 210 | (lambda (cnm &rest args) | ||
| 211 | (if (cl--generic-isnot-nnm-p cnm) | ||
| 212 | (apply cnm args))))) | ||
| 213 | method)) | ||
| 200 | 214 | ||
| 201 | ;; Compatibility with code which tries to catch `no-method-definition' errors. | 215 | ;; Compatibility with code which tries to catch `no-method-definition' errors. |
| 202 | (push 'no-method-definition (get 'cl-no-applicable-method 'error-conditions)) | 216 | (push 'no-method-definition (get 'cl-no-applicable-method 'error-conditions)) |
| @@ -212,7 +226,12 @@ Summary: | |||
| 212 | (apply #'cl-no-applicable-method method object args)) | 226 | (apply #'cl-no-applicable-method method object args)) |
| 213 | 227 | ||
| 214 | (define-obsolete-function-alias 'call-next-method 'cl-call-next-method "25.1") | 228 | (define-obsolete-function-alias 'call-next-method 'cl-call-next-method "25.1") |
| 215 | (define-obsolete-function-alias 'next-method-p 'cl-next-method-p "25.1") | 229 | (defun next-method-p () |
| 230 | (declare (obsolete cl-next-method-p "25.1")) | ||
| 231 | ;; EIEIO's `next-method-p' just returned nil when called in an | ||
| 232 | ;; invalid context. | ||
| 233 | (message "next-method-p called outside of a primary or around method") | ||
| 234 | nil) | ||
| 216 | 235 | ||
| 217 | ;;;###autoload | 236 | ;;;###autoload |
| 218 | (defun eieio-defmethod (method args) | 237 | (defun eieio-defmethod (method args) |
| @@ -225,11 +244,9 @@ Summary: | |||
| 225 | (defun eieio-defgeneric (method doc-string) | 244 | (defun eieio-defgeneric (method doc-string) |
| 226 | "Obsolete work part of an old version of the `defgeneric' macro." | 245 | "Obsolete work part of an old version of the `defgeneric' macro." |
| 227 | (declare (obsolete cl-defgeneric "24.1")) | 246 | (declare (obsolete cl-defgeneric "24.1")) |
| 228 | ;; Don't do this over and over. | 247 | (eval `(defgeneric ,method (x) ,@(if doc-string `(,doc-string)))) |
| 229 | (unless (fboundp 'method) | 248 | ;; Return the method |
| 230 | (eval `(defgeneric ,method (x) ,@(if doc-string `(,doc-string)))) | 249 | 'method) |
| 231 | ;; Return the method | ||
| 232 | 'method)) | ||
| 233 | 250 | ||
| 234 | ;;;###autoload | 251 | ;;;###autoload |
| 235 | (defun eieio-defclass (cname superclasses slots options) | 252 | (defun eieio-defclass (cname superclasses slots options) |
diff --git a/lisp/emacs-lisp/eieio-custom.el b/lisp/emacs-lisp/eieio-custom.el index 8ab74ae3352..0e0b31e4e7e 100644 --- a/lisp/emacs-lisp/eieio-custom.el +++ b/lisp/emacs-lisp/eieio-custom.el | |||
| @@ -322,7 +322,7 @@ Optional argument IGNORE is an extraneous parameter." | |||
| 322 | ;; This is the same object we had before. | 322 | ;; This is the same object we had before. |
| 323 | obj)) | 323 | obj)) |
| 324 | 324 | ||
| 325 | (defmethod eieio-done-customizing ((_obj eieio-default-superclass)) | 325 | (cl-defmethod eieio-done-customizing ((_obj eieio-default-superclass)) |
| 326 | "When applying change to a widget, call this method. | 326 | "When applying change to a widget, call this method. |
| 327 | This method is called by the default widget-edit commands. | 327 | This method is called by the default widget-edit commands. |
| 328 | User made commands should also call this method when applying changes. | 328 | User made commands should also call this method when applying changes. |
| @@ -345,7 +345,7 @@ Optional argument GROUP is the sub-group of slots to display." | |||
| 345 | "Major mode for customizing EIEIO objects. | 345 | "Major mode for customizing EIEIO objects. |
| 346 | \\{eieio-custom-mode-map}") | 346 | \\{eieio-custom-mode-map}") |
| 347 | 347 | ||
| 348 | (defmethod eieio-customize-object ((obj eieio-default-superclass) | 348 | (cl-defmethod eieio-customize-object ((obj eieio-default-superclass) |
| 349 | &optional group) | 349 | &optional group) |
| 350 | "Customize OBJ in a specialized custom buffer. | 350 | "Customize OBJ in a specialized custom buffer. |
| 351 | To override call the `eieio-custom-widget-insert' to just insert the | 351 | To override call the `eieio-custom-widget-insert' to just insert the |
| @@ -386,7 +386,7 @@ These groups are specified with the `:group' slot flag." | |||
| 386 | (make-local-variable 'eieio-cog) | 386 | (make-local-variable 'eieio-cog) |
| 387 | (setq eieio-cog g))) | 387 | (setq eieio-cog g))) |
| 388 | 388 | ||
| 389 | (defmethod eieio-custom-object-apply-reset ((_obj eieio-default-superclass)) | 389 | (cl-defmethod eieio-custom-object-apply-reset ((_obj eieio-default-superclass)) |
| 390 | "Insert an Apply and Reset button into the object editor. | 390 | "Insert an Apply and Reset button into the object editor. |
| 391 | Argument OBJ is the object being customized." | 391 | Argument OBJ is the object being customized." |
| 392 | (widget-create 'push-button | 392 | (widget-create 'push-button |
| @@ -417,7 +417,7 @@ Argument OBJ is the object being customized." | |||
| 417 | (bury-buffer)) | 417 | (bury-buffer)) |
| 418 | "Cancel")) | 418 | "Cancel")) |
| 419 | 419 | ||
| 420 | (defmethod eieio-custom-widget-insert ((obj eieio-default-superclass) | 420 | (cl-defmethod eieio-custom-widget-insert ((obj eieio-default-superclass) |
| 421 | &rest flags) | 421 | &rest flags) |
| 422 | "Insert the widget used for editing object OBJ in the current buffer. | 422 | "Insert the widget used for editing object OBJ in the current buffer. |
| 423 | Arguments FLAGS are widget compatible flags. | 423 | Arguments FLAGS are widget compatible flags. |
| @@ -446,7 +446,7 @@ Must return the created widget." | |||
| 446 | ;; These functions provide the ability to create dynamic menus to | 446 | ;; These functions provide the ability to create dynamic menus to |
| 447 | ;; customize specific sections of an object. They do not hook directly | 447 | ;; customize specific sections of an object. They do not hook directly |
| 448 | ;; into a filter, but can be used to create easymenu vectors. | 448 | ;; into a filter, but can be used to create easymenu vectors. |
| 449 | (defmethod eieio-customize-object-group ((obj eieio-default-superclass)) | 449 | (cl-defmethod eieio-customize-object-group ((obj eieio-default-superclass)) |
| 450 | "Create a list of vectors for customizing sections of OBJ." | 450 | "Create a list of vectors for customizing sections of OBJ." |
| 451 | (mapcar (lambda (group) | 451 | (mapcar (lambda (group) |
| 452 | (vector (concat "Group " (symbol-name group)) | 452 | (vector (concat "Group " (symbol-name group)) |
| @@ -457,7 +457,7 @@ Must return the created widget." | |||
| 457 | (defvar eieio-read-custom-group-history nil | 457 | (defvar eieio-read-custom-group-history nil |
| 458 | "History for the custom group reader.") | 458 | "History for the custom group reader.") |
| 459 | 459 | ||
| 460 | (defmethod eieio-read-customization-group ((obj eieio-default-superclass)) | 460 | (cl-defmethod eieio-read-customization-group ((obj eieio-default-superclass)) |
| 461 | "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. |
| 462 | Return the symbol for the group, or nil" | 462 | Return the symbol for the group, or nil" |
| 463 | (let ((g (eieio--class-option (eieio--object-class-object obj) | 463 | (let ((g (eieio--class-option (eieio--object-class-object obj) |
diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index ab8d41e4ac4..6534bd0fecf 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el | |||
| @@ -79,7 +79,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button." | |||
| 79 | ;; | 79 | ;; |
| 80 | ;; Each object should have an opportunity to show stuff about itself. | 80 | ;; Each object should have an opportunity to show stuff about itself. |
| 81 | 81 | ||
| 82 | (defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass) | 82 | (cl-defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass) |
| 83 | prefix) | 83 | prefix) |
| 84 | "Insert the slots of OBJ into the current DDEBUG buffer." | 84 | "Insert the slots of OBJ into the current DDEBUG buffer." |
| 85 | (let ((inhibit-read-only t)) | 85 | (let ((inhibit-read-only t)) |
| @@ -124,7 +124,7 @@ PREBUTTONTEXT is some text between PREFIX and the object button." | |||
| 124 | ;; | 124 | ;; |
| 125 | ;; A generic function to run DDEBUG on an object and popup a new buffer. | 125 | ;; A generic function to run DDEBUG on an object and popup a new buffer. |
| 126 | ;; | 126 | ;; |
| 127 | (defmethod data-debug-show ((obj eieio-default-superclass)) | 127 | (cl-defmethod data-debug-show ((obj eieio-default-superclass)) |
| 128 | "Run ddebug against any EIEIO object OBJ." | 128 | "Run ddebug against any EIEIO object OBJ." |
| 129 | (data-debug-new-buffer (format "*%s DDEBUG*" (eieio-object-name obj))) | 129 | (data-debug-new-buffer (format "*%s DDEBUG*" (eieio-object-name obj))) |
| 130 | (data-debug-insert-object-slots obj "]")) | 130 | (data-debug-insert-object-slots obj "]")) |
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index 13ad120a9b5..a131b02ee16 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el | |||
| @@ -122,29 +122,18 @@ If CLASS is actually an object, then also display current values of that object. | |||
| 122 | ;; Describe all the slots in this class. | 122 | ;; Describe all the slots in this class. |
| 123 | (eieio-help-class-slots class) | 123 | (eieio-help-class-slots class) |
| 124 | ;; Describe all the methods specific to this class. | 124 | ;; Describe all the methods specific to this class. |
| 125 | (let ((methods (eieio-all-generic-functions class)) | 125 | (let ((generics (eieio-all-generic-functions class))) |
| 126 | (type [":STATIC" ":BEFORE" ":PRIMARY" ":AFTER"]) | 126 | (when generics |
| 127 | counter doc) | ||
| 128 | (when methods | ||
| 129 | (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) | 127 | (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) |
| 130 | (while methods | 128 | (dolist (generic generics) |
| 131 | (setq doc (eieio-method-documentation (car methods) class)) | 129 | (insert "`") |
| 132 | (insert "`") | 130 | (help-insert-xref-button (symbol-name generic) 'help-function generic) |
| 133 | (help-insert-xref-button (symbol-name (car methods)) | 131 | (insert "'") |
| 134 | 'help-function (car methods)) | 132 | (pcase-dolist (`(,qualifier ,args ,doc) |
| 135 | (insert "'") | 133 | (eieio-method-documentation generic class)) |
| 136 | (if (not doc) | 134 | (insert (format " %S %S\n" qualifier args) |
| 137 | (insert " Undocumented") | 135 | (or doc ""))) |
| 138 | (setq counter 0) | 136 | (insert "\n\n"))))) |
| 139 | (dolist (cur doc) | ||
| 140 | (when cur | ||
| 141 | (insert " " (aref type counter) " " | ||
| 142 | (prin1-to-string (car cur) (current-buffer)) | ||
| 143 | "\n" | ||
| 144 | (or (cdr cur) ""))) | ||
| 145 | (setq counter (1+ counter)))) | ||
| 146 | (insert "\n\n") | ||
| 147 | (setq methods (cdr methods)))))) | ||
| 148 | 137 | ||
| 149 | (defun eieio-help-class-slots (class) | 138 | (defun eieio-help-class-slots (class) |
| 150 | "Print help description for the slots in CLASS. | 139 | "Print help description for the slots in CLASS. |
| @@ -311,6 +300,20 @@ are not abstract." | |||
| 311 | (eieio-help-class ctr)) | 300 | (eieio-help-class ctr)) |
| 312 | )))) | 301 | )))) |
| 313 | 302 | ||
| 303 | (defun eieio--specializers-apply-to-class-p (specializers class) | ||
| 304 | "Return non-nil if a method with SPECIALIZERS applies to CLASS." | ||
| 305 | (let ((applies nil)) | ||
| 306 | (dolist (specializer specializers) | ||
| 307 | (if (eq 'subclass (car-safe specializer)) | ||
| 308 | (setq specializer (nth 1 specializer))) | ||
| 309 | ;; Don't include the methods that are "too generic", such as those | ||
| 310 | ;; applying to `eieio-default-superclass'. | ||
| 311 | (and (not (memq specializer '(t eieio-default-superclass))) | ||
| 312 | (class-p specializer) | ||
| 313 | (child-of-class-p class specializer) | ||
| 314 | (setq applies t))) | ||
| 315 | applies)) | ||
| 316 | |||
| 314 | (defun eieio-all-generic-functions (&optional class) | 317 | (defun eieio-all-generic-functions (&optional class) |
| 315 | "Return a list of all generic functions. | 318 | "Return a list of all generic functions. |
| 316 | Optional CLASS argument returns only those functions that contain | 319 | Optional CLASS argument returns only those functions that contain |
| @@ -318,53 +321,31 @@ methods for CLASS." | |||
| 318 | (let ((l nil)) | 321 | (let ((l nil)) |
| 319 | (mapatoms | 322 | (mapatoms |
| 320 | (lambda (symbol) | 323 | (lambda (symbol) |
| 321 | (let ((tree (get symbol 'eieio-method-hashtable))) | 324 | (let ((generic (and (fboundp symbol) (cl--generic symbol)))) |
| 322 | (when tree | 325 | (and generic |
| 323 | ;; A symbol might be interned for that class in one of | 326 | (catch 'found |
| 324 | ;; these three slots in the method-obarray. | 327 | (if (null class) (throw 'found t)) |
| 325 | (if (or (not class) | 328 | (pcase-dolist (`((,specializers . ,_qualifier) . ,_) |
| 326 | (car (gethash class (aref tree 0))) | 329 | (cl--generic-method-table generic)) |
| 327 | (car (gethash class (aref tree 1))) | 330 | (if (eieio--specializers-apply-to-class-p |
| 328 | (car (gethash class (aref tree 2)))) | 331 | specializers class) |
| 329 | (setq l (cons symbol l))))))) | 332 | (throw 'found t)))) |
| 333 | (push symbol l))))) | ||
| 330 | l)) | 334 | l)) |
| 331 | 335 | ||
| 332 | (defun eieio-method-documentation (generic class) | 336 | (defun eieio-method-documentation (generic class) |
| 333 | "Return a list of the specific documentation of GENERIC for CLASS. | 337 | "Return info for all methods of GENERIC applicable to CLASS. |
| 334 | If there is not an explicit method for CLASS in GENERIC, or if that | 338 | The value returned is a list of elements of the form |
| 335 | function has no documentation, then return nil." | 339 | \(QUALIFIER ARGS DOC)." |
| 336 | (let ((tree (get generic 'eieio-method-hashtable))) | 340 | (let ((generic (cl--generic generic)) |
| 337 | (when tree | 341 | (docs ())) |
| 338 | ;; A symbol might be interned for that class in one of | 342 | (when generic |
| 339 | ;; these three slots in the method-hashtable. | 343 | (dolist (method (cl--generic-method-table generic)) |
| 340 | ;; FIXME: Where do these 0/1/2 come from? Isn't 0 for :static, | 344 | (pcase-let ((`((,specializers . ,_qualifier) . ,_) method)) |
| 341 | ;; 1 for before, and 2 for primary (and 3 for after)? | 345 | (when (eieio--specializers-apply-to-class-p |
| 342 | (let ((before (car (gethash class (aref tree 0)))) | 346 | specializers class) |
| 343 | (primary (car (gethash class (aref tree 1)))) | 347 | (push (cl--generic-method-info method) docs))))) |
| 344 | (after (car (gethash class (aref tree 2))))) | 348 | docs)) |
| 345 | (if (not (or before primary after)) | ||
| 346 | nil | ||
| 347 | (list (if before | ||
| 348 | (cons (help-function-arglist before) | ||
| 349 | (documentation before)) | ||
| 350 | nil) | ||
| 351 | (if primary | ||
| 352 | (cons (help-function-arglist primary) | ||
| 353 | (documentation primary)) | ||
| 354 | nil) | ||
| 355 | (if after | ||
| 356 | (cons (help-function-arglist after) | ||
| 357 | (documentation after)) | ||
| 358 | nil))))))) | ||
| 359 | |||
| 360 | (defvar eieio-read-generic nil | ||
| 361 | "History of the `eieio-read-generic' prompt.") | ||
| 362 | |||
| 363 | (defun eieio-read-generic (prompt &optional historyvar) | ||
| 364 | "Read a generic function from the minibuffer with PROMPT. | ||
| 365 | Optional argument HISTORYVAR is the variable to use as history." | ||
| 366 | (intern (completing-read prompt obarray #'generic-p | ||
| 367 | t nil (or historyvar 'eieio-read-generic)))) | ||
| 368 | 349 | ||
| 369 | ;;; METHOD STATS | 350 | ;;; METHOD STATS |
| 370 | ;; | 351 | ;; |
diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el index b236f0f03e1..a1eabcf9700 100644 --- a/lisp/emacs-lisp/eieio-speedbar.el +++ b/lisp/emacs-lisp/eieio-speedbar.el | |||
| @@ -196,19 +196,19 @@ that path." | |||
| 196 | ;; when no other methods are found, allowing multiple inheritance to work | 196 | ;; when no other methods are found, allowing multiple inheritance to work |
| 197 | ;; reliably with eieio-speedbar. | 197 | ;; reliably with eieio-speedbar. |
| 198 | 198 | ||
| 199 | (defmethod eieio-speedbar-description (object) | 199 | (cl-defmethod eieio-speedbar-description (object) |
| 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 | (cl-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 | ||
| 207 | (defmethod eieio-speedbar-object-buttonname (object) | 207 | (cl-defmethod eieio-speedbar-object-buttonname (object) |
| 208 | "Return a string to use as a speedbar button for OBJECT." | 208 | "Return a string to use as a speedbar button for OBJECT." |
| 209 | (eieio-object-name-string object)) | 209 | (eieio-object-name-string object)) |
| 210 | 210 | ||
| 211 | (defmethod eieio-speedbar-make-tag-line (object depth) | 211 | (cl-defmethod eieio-speedbar-make-tag-line (object depth) |
| 212 | "Insert a tag line into speedbar at point for OBJECT. | 212 | "Insert a tag line into speedbar at point for OBJECT. |
| 213 | By default, all objects appear as simple TAGS with no need to inherit from | 213 | By default, all objects appear as simple TAGS with no need to inherit from |
| 214 | the special `eieio-speedbar' classes. Child classes should redefine this | 214 | the special `eieio-speedbar' classes. Child classes should redefine this |
| @@ -221,7 +221,7 @@ Argument DEPTH is the depth at which the tag line is inserted." | |||
| 221 | 'speedbar-tag-face | 221 | 'speedbar-tag-face |
| 222 | depth)) | 222 | depth)) |
| 223 | 223 | ||
| 224 | (defmethod eieio-speedbar-handle-click (object) | 224 | (cl-defmethod eieio-speedbar-handle-click (object) |
| 225 | "Handle a click action on OBJECT in speedbar. | 225 | "Handle a click action on OBJECT in speedbar. |
| 226 | Any object can be represented as a tag in SPEEDBAR without special | 226 | Any object can be represented as a tag in SPEEDBAR without special |
| 227 | attributes. These default objects will be pulled up in a custom | 227 | attributes. These default objects will be pulled up in a custom |
| @@ -285,7 +285,7 @@ Add one of the child classes to this class to the parent list of a class." | |||
| 285 | 285 | ||
| 286 | ;;; Methods to eieio-speedbar-* which do not need to be overridden | 286 | ;;; Methods to eieio-speedbar-* which do not need to be overridden |
| 287 | ;; | 287 | ;; |
| 288 | (defmethod eieio-speedbar-make-tag-line ((object eieio-speedbar) | 288 | (cl-defmethod eieio-speedbar-make-tag-line ((object eieio-speedbar) |
| 289 | depth) | 289 | depth) |
| 290 | "Insert a tag line into speedbar at point for OBJECT. | 290 | "Insert a tag line into speedbar at point for OBJECT. |
| 291 | All objects a child of symbol `eieio-speedbar' can be created from | 291 | All objects a child of symbol `eieio-speedbar' can be created from |
| @@ -321,12 +321,12 @@ 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 | (cl-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))) |
| 328 | 328 | ||
| 329 | (defmethod eieio-speedbar-expand ((object eieio-speedbar) depth) | 329 | (cl-defmethod eieio-speedbar-expand ((object eieio-speedbar) depth) |
| 330 | "Expand OBJECT at indentation DEPTH. | 330 | "Expand OBJECT at indentation DEPTH. |
| 331 | Inserts a list of new tag lines representing expanded elements within | 331 | Inserts a list of new tag lines representing expanded elements within |
| 332 | OBJECT." | 332 | OBJECT." |
| @@ -362,7 +362,7 @@ TOKEN is the object. INDENT is the current indentation level." | |||
| 362 | (t (error "Ooops... not sure what to do"))) | 362 | (t (error "Ooops... not sure what to do"))) |
| 363 | (speedbar-center-buffer-smartly)) | 363 | (speedbar-center-buffer-smartly)) |
| 364 | 364 | ||
| 365 | (defmethod eieio-speedbar-child-description ((obj eieio-speedbar)) | 365 | (cl-defmethod eieio-speedbar-child-description ((obj eieio-speedbar)) |
| 366 | "Return a description for a child of OBJ which is not an object." | 366 | "Return a description for a child of OBJ which is not an object." |
| 367 | (error "You must implement `eieio-speedbar-child-description' for %s" | 367 | (error "You must implement `eieio-speedbar-child-description' for %s" |
| 368 | (eieio-object-name obj))) | 368 | (eieio-object-name obj))) |
| @@ -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 | (cl-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 b64eba1de1f..7672d7f0b6e 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el | |||
| @@ -179,36 +179,31 @@ and reference them using the function `class-option'." | |||
| 179 | ;; of the specified name, and also performs a `defsetf' if applicable | 179 | ;; of the specified name, and also performs a `defsetf' if applicable |
| 180 | ;; so that users can `setf' the space returned by this function. | 180 | ;; so that users can `setf' the space returned by this function. |
| 181 | (when acces | 181 | (when acces |
| 182 | ;; FIXME: The defmethod below only defines a part of the generic | 182 | (push `(cl-defmethod (setf ,acces) (value (this ,name)) |
| 183 | ;; function (good), but the define-setter below affects the whole | 183 | (eieio-oset this ',sname value)) |
| 184 | ;; generic function (bad)! | ||
| 185 | (push `(gv-define-setter ,acces (store object) | ||
| 186 | ;; Apparently, eieio-oset-default doesn't work like | ||
| 187 | ;; oref-default and only accept class arguments! | ||
| 188 | (list ',(if nil ;; (eq alloc :class) | ||
| 189 | 'eieio-oset-default | ||
| 190 | 'eieio-oset) | ||
| 191 | object '',sname store)) | ||
| 192 | accessors) | 184 | accessors) |
| 193 | (push `(defmethod ,acces ,(if (eq alloc :class) :static :primary) | 185 | (push `(cl-defmethod ,acces ((this ,name)) |
| 194 | ((this ,name)) | ||
| 195 | ,(format | 186 | ,(format |
| 196 | "Retrieve the slot `%S' from an object of class `%S'." | 187 | "Retrieve the slot `%S' from an object of class `%S'." |
| 197 | sname name) | 188 | sname name) |
| 198 | (if (slot-boundp this ',sname) | 189 | ;; FIXME: Why is this different from the :reader case? |
| 199 | ;; Use oref-default for :class allocated slots, since | 190 | (if (slot-boundp this ',sname) (eieio-oref this ',sname))) |
| 200 | ;; these also accept the use of a class argument instead | 191 | accessors) |
| 201 | ;; of an object argument. | 192 | (when (and eieio-backward-compatibility (eq alloc :class)) |
| 202 | (,(if (eq alloc :class) 'eieio-oref-default 'eieio-oref) | 193 | ;; FIXME: How could I declare this *method* as obsolete. |
| 203 | this ',sname) | 194 | (push `(cl-defmethod ,acces ((this (subclass ,name))) |
| 204 | ;; Else - Some error? nil? | 195 | ,(format |
| 205 | nil)) | 196 | "Retrieve the class slot `%S' from a class `%S'. |
| 206 | accessors)) | 197 | This method is obsolete." |
| 198 | sname name) | ||
| 199 | (if (slot-boundp this ',sname) | ||
| 200 | (eieio-oref-default this ',sname))) | ||
| 201 | accessors))) | ||
| 207 | 202 | ||
| 208 | ;; If a writer is defined, then create a generic method of that | 203 | ;; If a writer is defined, then create a generic method of that |
| 209 | ;; name whose purpose is to set the value of the slot. | 204 | ;; name whose purpose is to set the value of the slot. |
| 210 | (if writer | 205 | (if writer |
| 211 | (push `(defmethod ,writer ((this ,name) value) | 206 | (push `(cl-defmethod ,writer ((this ,name) value) |
| 212 | ,(format "Set the slot `%S' of an object of class `%S'." | 207 | ,(format "Set the slot `%S' of an object of class `%S'." |
| 213 | sname name) | 208 | sname name) |
| 214 | (setf (slot-value this ',sname) value)) | 209 | (setf (slot-value this ',sname) value)) |
| @@ -216,7 +211,7 @@ and reference them using the function `class-option'." | |||
| 216 | ;; If a reader is defined, then create a generic method | 211 | ;; If a reader is defined, then create a generic method |
| 217 | ;; of that name whose purpose is to access this slot value. | 212 | ;; of that name whose purpose is to access this slot value. |
| 218 | (if reader | 213 | (if reader |
| 219 | (push `(defmethod ,reader ((this ,name)) | 214 | (push `(cl-defmethod ,reader ((this ,name)) |
| 220 | ,(format "Access the slot `%S' from object of class `%S'." | 215 | ,(format "Access the slot `%S' from object of class `%S'." |
| 221 | sname name) | 216 | sname name) |
| 222 | (slot-value this ',sname)) | 217 | (slot-value this ',sname)) |
| @@ -372,6 +367,10 @@ variable name of the same name as the slot." | |||
| 372 | (define-obsolete-function-alias | 367 | (define-obsolete-function-alias |
| 373 | 'object-class-fast #'eieio--object-class-name "24.4") | 368 | 'object-class-fast #'eieio--object-class-name "24.4") |
| 374 | 369 | ||
| 370 | (cl-defgeneric eieio-object-name-string (obj) | ||
| 371 | "Return a string which is OBJ's name." | ||
| 372 | (declare (obsolete eieio-named "25.1"))) | ||
| 373 | |||
| 375 | (defun eieio-object-name (obj &optional extra) | 374 | (defun eieio-object-name (obj &optional extra) |
| 376 | "Return a Lisp like symbol string for object OBJ. | 375 | "Return a Lisp like symbol string for object OBJ. |
| 377 | If EXTRA, include that in the string returned to represent the symbol." | 376 | If EXTRA, include that in the string returned to represent the symbol." |
| @@ -386,15 +385,13 @@ If EXTRA, include that in the string returned to represent the symbol." | |||
| 386 | ;; below "for free". Since this field is very rarely used, we got rid of it | 385 | ;; below "for free". Since this field is very rarely used, we got rid of it |
| 387 | ;; and instead we keep it in a weak hash-tables, for those very rare objects | 386 | ;; and instead we keep it in a weak hash-tables, for those very rare objects |
| 388 | ;; that use it. | 387 | ;; that use it. |
| 389 | (defmethod eieio-object-name-string (obj) | 388 | (cl-defmethod eieio-object-name-string (obj) |
| 390 | "Return a string which is OBJ's name." | ||
| 391 | (declare (obsolete eieio-named "25.1")) | ||
| 392 | (or (gethash obj eieio--object-names) | 389 | (or (gethash obj eieio--object-names) |
| 393 | (symbol-name (eieio-object-class obj)))) | 390 | (symbol-name (eieio-object-class obj)))) |
| 394 | (define-obsolete-function-alias | 391 | (define-obsolete-function-alias |
| 395 | 'object-name-string #'eieio-object-name-string "24.4") | 392 | 'object-name-string #'eieio-object-name-string "24.4") |
| 396 | 393 | ||
| 397 | (defmethod eieio-object-set-name-string (obj name) | 394 | (cl-defmethod eieio-object-set-name-string (obj name) |
| 398 | "Set the string which is OBJ's NAME." | 395 | "Set the string which is OBJ's NAME." |
| 399 | (declare (obsolete eieio-named "25.1")) | 396 | (declare (obsolete eieio-named "25.1")) |
| 400 | (eieio--check-type stringp name) | 397 | (eieio--check-type stringp name) |
| @@ -648,13 +645,13 @@ This class is not stored in the `parent' slot of a class vector." | |||
| 648 | 645 | ||
| 649 | (defalias 'standard-class 'eieio-default-superclass) | 646 | (defalias 'standard-class 'eieio-default-superclass) |
| 650 | 647 | ||
| 651 | (defgeneric eieio-constructor (class &rest slots) | 648 | (cl-defgeneric eieio-constructor (class &rest slots) |
| 652 | "Default constructor for CLASS `eieio-default-superclass'.") | 649 | "Default constructor for CLASS `eieio-default-superclass'.") |
| 653 | 650 | ||
| 654 | (define-obsolete-function-alias 'constructor #'eieio-constructor "25.1") | 651 | (define-obsolete-function-alias 'constructor #'eieio-constructor "25.1") |
| 655 | 652 | ||
| 656 | (defmethod eieio-constructor :static | 653 | (cl-defmethod eieio-constructor |
| 657 | ((class eieio-default-superclass) &rest slots) | 654 | ((class (subclass eieio-default-superclass)) &rest slots) |
| 658 | "Default constructor for CLASS `eieio-default-superclass'. | 655 | "Default constructor for CLASS `eieio-default-superclass'. |
| 659 | SLOTS are the initialization slots used by `shared-initialize'. | 656 | SLOTS are the initialization slots used by `shared-initialize'. |
| 660 | This static method is called when an object is constructed. | 657 | This static method is called when an object is constructed. |
| @@ -674,11 +671,11 @@ calls `shared-initialize' on that object." | |||
| 674 | ;; Return the created object. | 671 | ;; Return the created object. |
| 675 | new-object)) | 672 | new-object)) |
| 676 | 673 | ||
| 677 | (defgeneric shared-initialize (obj slots) | 674 | (cl-defgeneric shared-initialize (obj slots) |
| 678 | "Set slots of OBJ with SLOTS which is a list of name/value pairs. | 675 | "Set slots of OBJ with SLOTS which is a list of name/value pairs. |
| 679 | Called from the constructor routine.") | 676 | Called from the constructor routine.") |
| 680 | 677 | ||
| 681 | (defmethod shared-initialize ((obj eieio-default-superclass) slots) | 678 | (cl-defmethod shared-initialize ((obj eieio-default-superclass) slots) |
| 682 | "Set slots of OBJ with SLOTS which is a list of name/value pairs. | 679 | "Set slots of OBJ with SLOTS which is a list of name/value pairs. |
| 683 | Called from the constructor routine." | 680 | Called from the constructor routine." |
| 684 | (while slots | 681 | (while slots |
| @@ -689,10 +686,10 @@ Called from the constructor routine." | |||
| 689 | (eieio-oset obj rn (car (cdr slots))))) | 686 | (eieio-oset obj rn (car (cdr slots))))) |
| 690 | (setq slots (cdr (cdr slots))))) | 687 | (setq slots (cdr (cdr slots))))) |
| 691 | 688 | ||
| 692 | (defgeneric initialize-instance (this &optional slots) | 689 | (cl-defgeneric initialize-instance (this &optional slots) |
| 693 | "Construct the new object THIS based on SLOTS.") | 690 | "Construct the new object THIS based on SLOTS.") |
| 694 | 691 | ||
| 695 | (defmethod initialize-instance ((this eieio-default-superclass) | 692 | (cl-defmethod initialize-instance ((this eieio-default-superclass) |
| 696 | &optional slots) | 693 | &optional slots) |
| 697 | "Construct the new object THIS based on SLOTS. | 694 | "Construct the new object THIS based on SLOTS. |
| 698 | SLOTS is a tagged list where odd numbered elements are tags, and | 695 | SLOTS is a tagged list where odd numbered elements are tags, and |
| @@ -724,10 +721,10 @@ dynamically set from SLOTS." | |||
| 724 | ;; Shared initialize will parse our slots for us. | 721 | ;; Shared initialize will parse our slots for us. |
| 725 | (shared-initialize this slots)) | 722 | (shared-initialize this slots)) |
| 726 | 723 | ||
| 727 | (defgeneric slot-missing (object slot-name operation &optional new-value) | 724 | (cl-defgeneric slot-missing (object slot-name operation &optional new-value) |
| 728 | "Method invoked when an attempt to access a slot in OBJECT fails.") | 725 | "Method invoked when an attempt to access a slot in OBJECT fails.") |
| 729 | 726 | ||
| 730 | (defmethod slot-missing ((object eieio-default-superclass) slot-name | 727 | (cl-defmethod slot-missing ((object eieio-default-superclass) slot-name |
| 731 | _operation &optional _new-value) | 728 | _operation &optional _new-value) |
| 732 | "Method invoked when an attempt to access a slot in OBJECT fails. | 729 | "Method invoked when an attempt to access a slot in OBJECT fails. |
| 733 | SLOT-NAME is the name of the failed slot, OPERATION is the type of access | 730 | SLOT-NAME is the name of the failed slot, OPERATION is the type of access |
| @@ -739,10 +736,10 @@ directly reference slots in EIEIO objects." | |||
| 739 | (signal 'invalid-slot-name (list (eieio-object-name object) | 736 | (signal 'invalid-slot-name (list (eieio-object-name object) |
| 740 | slot-name))) | 737 | slot-name))) |
| 741 | 738 | ||
| 742 | (defgeneric slot-unbound (object class slot-name fn) | 739 | (cl-defgeneric slot-unbound (object class slot-name fn) |
| 743 | "Slot unbound is invoked during an attempt to reference an unbound slot.") | 740 | "Slot unbound is invoked during an attempt to reference an unbound slot.") |
| 744 | 741 | ||
| 745 | (defmethod slot-unbound ((object eieio-default-superclass) | 742 | (cl-defmethod slot-unbound ((object eieio-default-superclass) |
| 746 | class slot-name fn) | 743 | class slot-name fn) |
| 747 | "Slot unbound is invoked during an attempt to reference an unbound slot. | 744 | "Slot unbound is invoked during an attempt to reference an unbound slot. |
| 748 | OBJECT is the instance of the object being reference. CLASS is the | 745 | OBJECT is the instance of the object being reference. CLASS is the |
| @@ -757,14 +754,14 @@ EIEIO can only dispatch on the first argument, so the first two are swapped." | |||
| 757 | (signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name object) | 754 | (signal 'unbound-slot (list (eieio-class-name class) (eieio-object-name object) |
| 758 | slot-name fn))) | 755 | slot-name fn))) |
| 759 | 756 | ||
| 760 | (defgeneric clone (obj &rest params) | 757 | (cl-defgeneric clone (obj &rest params) |
| 761 | "Make a copy of OBJ, and then supply PARAMS. | 758 | "Make a copy of OBJ, and then supply PARAMS. |
| 762 | PARAMS is a parameter list of the same form used by `initialize-instance'. | 759 | PARAMS is a parameter list of the same form used by `initialize-instance'. |
| 763 | 760 | ||
| 764 | When overloading `clone', be sure to call `call-next-method' | 761 | When overloading `clone', be sure to call `call-next-method' |
| 765 | first and modify the returned object.") | 762 | first and modify the returned object.") |
| 766 | 763 | ||
| 767 | (defmethod clone ((obj eieio-default-superclass) &rest params) | 764 | (cl-defmethod clone ((obj eieio-default-superclass) &rest params) |
| 768 | "Make a copy of OBJ, and then apply PARAMS." | 765 | "Make a copy of OBJ, and then apply PARAMS." |
| 769 | (let ((nobj (copy-sequence obj))) | 766 | (let ((nobj (copy-sequence obj))) |
| 770 | (if (stringp (car params)) | 767 | (if (stringp (car params)) |
| @@ -773,24 +770,24 @@ first and modify the returned object.") | |||
| 773 | (if params (shared-initialize nobj params)) | 770 | (if params (shared-initialize nobj params)) |
| 774 | nobj)) | 771 | nobj)) |
| 775 | 772 | ||
| 776 | (defgeneric destructor (this &rest params) | 773 | (cl-defgeneric destructor (this &rest params) |
| 777 | "Destructor for cleaning up any dynamic links to our object.") | 774 | "Destructor for cleaning up any dynamic links to our object.") |
| 778 | 775 | ||
| 779 | (defmethod destructor ((_this eieio-default-superclass) &rest _params) | 776 | (cl-defmethod destructor ((_this eieio-default-superclass) &rest _params) |
| 780 | "Destructor for cleaning up any dynamic links to our object. | 777 | "Destructor for cleaning up any dynamic links to our object. |
| 781 | Argument THIS is the object being destroyed. PARAMS are additional | 778 | Argument THIS is the object being destroyed. PARAMS are additional |
| 782 | ignored parameters." | 779 | ignored parameters." |
| 783 | ;; No cleanup... yet. | 780 | ;; No cleanup... yet. |
| 784 | ) | 781 | ) |
| 785 | 782 | ||
| 786 | (defgeneric object-print (this &rest strings) | 783 | (cl-defgeneric object-print (this &rest strings) |
| 787 | "Pretty printer for object THIS. Call function `object-name' with STRINGS. | 784 | "Pretty printer for object THIS. Call function `object-name' with STRINGS. |
| 788 | 785 | ||
| 789 | It is sometimes useful to put a summary of the object into the | 786 | It is sometimes useful to put a summary of the object into the |
| 790 | default #<notation> string when using EIEIO browsing tools. | 787 | default #<notation> string when using EIEIO browsing tools. |
| 791 | Implement this method to customize the summary.") | 788 | Implement this method to customize the summary.") |
| 792 | 789 | ||
| 793 | (defmethod object-print ((this eieio-default-superclass) &rest strings) | 790 | (cl-defmethod object-print ((this eieio-default-superclass) &rest strings) |
| 794 | "Pretty printer for object THIS. Call function `object-name' with STRINGS. | 791 | "Pretty printer for object THIS. Call function `object-name' with STRINGS. |
| 795 | The default method for printing object THIS is to use the | 792 | The default method for printing object THIS is to use the |
| 796 | function `object-name'. | 793 | function `object-name'. |
| @@ -807,11 +804,11 @@ to prepend a space." | |||
| 807 | (defvar eieio-print-depth 0 | 804 | (defvar eieio-print-depth 0 |
| 808 | "When printing, keep track of the current indentation depth.") | 805 | "When printing, keep track of the current indentation depth.") |
| 809 | 806 | ||
| 810 | (defgeneric object-write (this &optional comment) | 807 | (cl-defgeneric object-write (this &optional comment) |
| 811 | "Write out object THIS to the current stream. | 808 | "Write out object THIS to the current stream. |
| 812 | Optional COMMENT will add comments to the beginning of the output.") | 809 | Optional COMMENT will add comments to the beginning of the output.") |
| 813 | 810 | ||
| 814 | (defmethod object-write ((this eieio-default-superclass) &optional comment) | 811 | (cl-defmethod object-write ((this eieio-default-superclass) &optional comment) |
| 815 | "Write object THIS out to the current stream. | 812 | "Write object THIS out to the current stream. |
| 816 | This writes out the vector version of this object. Complex and recursive | 813 | This writes out the vector version of this object. Complex and recursive |
| 817 | object are discouraged from being written. | 814 | object are discouraged from being written. |
diff --git a/test/ChangeLog b/test/ChangeLog index dcce0bf3c39..d63a561953d 100644 --- a/test/ChangeLog +++ b/test/ChangeLog | |||
| @@ -1,7 +1,12 @@ | |||
| 1 | 2015-01-21 Stefan Monnier <monnier@iro.umontreal.ca> | ||
| 2 | |||
| 3 | * automated/cl-generic-tests.el (setf cl--generic-2): Make sure | ||
| 4 | the setf can be used already in the body of the method. | ||
| 5 | |||
| 1 | 2015-01-20 Jorgen Schaefer <contact@jorgenschaefer.de> | 6 | 2015-01-20 Jorgen Schaefer <contact@jorgenschaefer.de> |
| 2 | 7 | ||
| 3 | * automated/package-test.el (package-test-install-prioritized): | 8 | * automated/package-test.el (package-test-install-prioritized): |
| 4 | Removed test due to unreproducable failures. | 9 | Remove test due to unreproducable failures. |
| 5 | 10 | ||
| 6 | 2015-01-20 Michal Nazarewicz <mina86@mina86.com> | 11 | 2015-01-20 Michal Nazarewicz <mina86@mina86.com> |
| 7 | 12 | ||
| @@ -15,8 +20,8 @@ | |||
| 15 | A new helper function for testing `tildify-double-space-undos' | 20 | A new helper function for testing `tildify-double-space-undos' |
| 16 | behaviour in the `tildify-space' function. | 21 | behaviour in the `tildify-space' function. |
| 17 | (tildify-space-undo-test-html, tildify-space-undo-test-html-nbsp) | 22 | (tildify-space-undo-test-html, tildify-space-undo-test-html-nbsp) |
| 18 | (tildify-space-undo-test-xml, tildify-space-undo-test-tex): New | 23 | (tildify-space-undo-test-xml, tildify-space-undo-test-tex): |
| 19 | tests for `tildify-doule-space-undos' behaviour. | 24 | New tests for `tildify-doule-space-undos' behaviour. |
| 20 | 25 | ||
| 21 | * automated/tildify-tests.el (tildify-space-test--test): | 26 | * automated/tildify-tests.el (tildify-space-test--test): |
| 22 | A new helper function for testing `tildify-space' function. | 27 | A new helper function for testing `tildify-space' function. |
diff --git a/test/automated/cl-generic-tests.el b/test/automated/cl-generic-tests.el index 1c01d9b164b..bc9a1ece423 100644 --- a/test/automated/cl-generic-tests.el +++ b/test/automated/cl-generic-tests.el | |||
| @@ -73,6 +73,11 @@ | |||
| 73 | (should (equal (cl--generic-1 (make-cl-generic-struct-child11) nil) | 73 | (should (equal (cl--generic-1 (make-cl-generic-struct-child11) nil) |
| 74 | '("child11" "around""child1" "parent" a)))) | 74 | '("child11" "around""child1" "parent" a)))) |
| 75 | 75 | ||
| 76 | ;; I don't know how to put this inside an `ert-test'. This tests that `setf' | ||
| 77 | ;; can be used directly inside the body of the setf method. | ||
| 78 | (cl-defmethod (setf cl--generic-2) (v (y integer) z) | ||
| 79 | (setf (cl--generic-2 (nth y z) z) v)) | ||
| 80 | |||
| 76 | (ert-deftest cl-generic-test-03-setf () | 81 | (ert-deftest cl-generic-test-03-setf () |
| 77 | (cl-defmethod (setf cl--generic-1) (v (y t) z) (list v y z)) | 82 | (cl-defmethod (setf cl--generic-1) (v (y t) z) (list v y z)) |
| 78 | (cl-defmethod (setf cl--generic-1) (v (_y (eql 4)) z) (list v "four" z)) | 83 | (cl-defmethod (setf cl--generic-1) (v (_y (eql 4)) z) (list v "four" z)) |
diff --git a/test/automated/eieio-test-methodinvoke.el b/test/automated/eieio-test-methodinvoke.el index 3918fb904fe..da5f59a4654 100644 --- a/test/automated/eieio-test-methodinvoke.el +++ b/test/automated/eieio-test-methodinvoke.el | |||
| @@ -292,6 +292,7 @@ | |||
| 292 | 292 | ||
| 293 | (defmethod initialize-instance :after ((this eitest-Ja) &rest slots) | 293 | (defmethod initialize-instance :after ((this eitest-Ja) &rest slots) |
| 294 | ;(message "+Ja") | 294 | ;(message "+Ja") |
| 295 | ;; FIXME: Using next-method-p in an after-method is invalid! | ||
| 295 | (when (next-method-p) | 296 | (when (next-method-p) |
| 296 | (call-next-method)) | 297 | (call-next-method)) |
| 297 | ;(message "-Ja") | 298 | ;(message "-Ja") |
| @@ -302,6 +303,7 @@ | |||
| 302 | 303 | ||
| 303 | (defmethod initialize-instance :after ((this eitest-Jb) &rest slots) | 304 | (defmethod initialize-instance :after ((this eitest-Jb) &rest slots) |
| 304 | ;(message "+Jb") | 305 | ;(message "+Jb") |
| 306 | ;; FIXME: Using next-method-p in an after-method is invalid! | ||
| 305 | (when (next-method-p) | 307 | (when (next-method-p) |
| 306 | (call-next-method)) | 308 | (call-next-method)) |
| 307 | ;(message "-Jb") | 309 | ;(message "-Jb") |