diff options
| author | Stefan Monnier | 2015-07-07 02:14:16 -0400 |
|---|---|---|
| committer | Stefan Monnier | 2015-07-07 02:14:16 -0400 |
| commit | 59b5723c9b613f14cd60cd3239cfdbc0d2343b18 (patch) | |
| tree | 923edc0b04619ab41af69078d8cd9e3f86df5038 | |
| parent | 287bce988895b104c33d53faacfffd91d8d8e0f1 (diff) | |
| download | emacs-59b5723c9b613f14cd60cd3239cfdbc0d2343b18.tar.gz emacs-59b5723c9b613f14cd60cd3239cfdbc0d2343b18.zip | |
Add online-help support to describe types
* lisp/help-fns.el (describe-symbol-backends): Move to help-mode.el.
(describe-symbol): Improve the selection of default.
* lisp/help-mode.el: Require cl-lib.
(describe-symbol-backends): Move from help-fns.el.
(help-make-xrefs): Use it.
* lisp/emacs-lisp/cl-extra.el (describe-symbol-backends): Add entry
for types.
(cl--typedef-regexp): New const.
(find-function-regexp-alist): Add entry for types.
(cl-help-type, cl-type-definition): New buttons.
(cl-find-class): New function.
(cl-describe-type): New command.
(cl--describe-class, cl--describe-class-slot)
(cl--describe-class-slots): New functions, moved from eieio-opt.el.
* lisp/emacs-lisp/cl-generic.el (cl--generic-method-documentation)
(cl--generic-all-functions, cl--generic-specializers-apply-to-type-p):
New functions. Moved from eieio-opt.el.
(cl--generic-class-parents): New function, extracted from
cl--generic-struct-specializers.
(cl--generic-struct-specializers): Use it.
* lisp/emacs-lisp/cl-macs.el (cl-defstruct): Use pcase-dolist.
Improve constructor's docstrings.
(cl-struct-unknown-slot): New error.
(cl-struct-slot-offset): Use it.
* lisp/emacs-lisp/cl-preloaded.el (cl-struct-define): Record the type
definition in current-load-list.
* lisp/emacs-lisp/eieio-core.el (eieio--known-slot-names): New var.
(eieio--add-new-slot): Set it.
(eieio-defclass-internal): Use new name for current-load-list.
(eieio-oref): Add compiler-macro to warn about unknown slots.
* lisp/emacs-lisp/eieio.el (defclass): Update eieio--known-slot-names
as compile-time as well. Improve constructor docstrings.
* lisp/emacs-lisp/eieio-opt.el (eieio-help-class)
(eieio--help-print-slot, eieio-help-class-slots): Move to cl-extra.el.
(eieio-class-def): Remove button.
(eieio-help-constructor): Use new name for load-history element.
(eieio--specializers-apply-to-class-p, eieio-all-generic-functions)
(eieio-method-documentation): Move to cl-generic.el.
(eieio-display-method-list): Use new names.
* lisp/emacs-lisp/lisp-mode.el (lisp-imenu-generic-expression):
Add "define-linline".
(lisp-fdefs): Remove "defsubst".
(el-fdefs): Add "defsubst", "cl-defsubst", and "define-linline".
* lisp/emacs-lisp/macroexp.el (macroexp--warned): New var.
(macroexp--warn-and-return): Use it to avoid inf-loops.
Add `compile-only' argument.
| -rw-r--r-- | lisp/emacs-lisp/cl-extra.el | 163 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-generic.el | 71 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 22 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-preloaded.el | 1 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-core.el | 96 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio-opt.el | 156 | ||||
| -rw-r--r-- | lisp/emacs-lisp/eieio.el | 19 | ||||
| -rw-r--r-- | lisp/emacs-lisp/lisp-mode.el | 7 | ||||
| -rw-r--r-- | lisp/emacs-lisp/macroexp.el | 52 | ||||
| -rw-r--r-- | lisp/help-fns.el | 23 | ||||
| -rw-r--r-- | lisp/help-mode.el | 38 |
11 files changed, 360 insertions, 288 deletions
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 3313cc77db5..38cc772e8b0 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el | |||
| @@ -688,6 +688,169 @@ including `cl-block' and `cl-eval-when'." | |||
| 688 | (prog1 (cl-prettyprint form) | 688 | (prog1 (cl-prettyprint form) |
| 689 | (message "")))) | 689 | (message "")))) |
| 690 | 690 | ||
| 691 | ;;; Integration into the online help system. | ||
| 692 | |||
| 693 | (eval-when-compile (require 'cl-macs)) ;Explicitly, for cl--find-class. | ||
| 694 | (require 'help-mode) | ||
| 695 | |||
| 696 | ;; FIXME: We could go crazy and add another entry so describe-symbol can be | ||
| 697 | ;; used with the slot names of CL structs (and/or EIEIO objects). | ||
| 698 | (add-to-list 'describe-symbol-backends | ||
| 699 | `(nil ,#'cl-find-class ,(lambda (s _b _f) (cl-describe-type s)))) | ||
| 700 | |||
| 701 | (defconst cl--typedef-regexp | ||
| 702 | (concat "(" (regexp-opt '("defclass" "defstruct" "cl-defstruct" | ||
| 703 | "cl-deftype" "deftype")) | ||
| 704 | "[ \t\r\n]+%s[ \t\r\n]+")) | ||
| 705 | (with-eval-after-load 'find-func | ||
| 706 | (defvar find-function-regexp-alist) | ||
| 707 | (add-to-list 'find-function-regexp-alist | ||
| 708 | `(define-type . cl--typedef-regexp))) | ||
| 709 | |||
| 710 | (define-button-type 'cl-help-type | ||
| 711 | :supertype 'help-function-def | ||
| 712 | 'help-function #'cl-describe-type | ||
| 713 | 'help-echo (purecopy "mouse-2, RET: describe this type")) | ||
| 714 | |||
| 715 | (define-button-type 'cl-type-definition | ||
| 716 | :supertype 'help-function-def | ||
| 717 | 'help-echo (purecopy "mouse-2, RET: find type definition")) | ||
| 718 | |||
| 719 | (declare-function help-fns-short-filename "help-fns" (filename)) | ||
| 720 | |||
| 721 | ;;;###autoload | ||
| 722 | (defun cl-find-class (type) (cl--find-class type)) | ||
| 723 | |||
| 724 | ;;;###autoload | ||
| 725 | (defun cl-describe-type (type) | ||
| 726 | "Display the documentation for type TYPE (a symbol)." | ||
| 727 | (interactive | ||
| 728 | (let ((str (completing-read "Describe type: " obarray #'cl-find-class t))) | ||
| 729 | (if (<= (length str) 0) | ||
| 730 | (user-error "Abort!") | ||
| 731 | (list (intern str))))) | ||
| 732 | (help-setup-xref (list #'cl-describe-type type) | ||
| 733 | (called-interactively-p 'interactive)) | ||
| 734 | (save-excursion | ||
| 735 | (with-help-window (help-buffer) | ||
| 736 | (with-current-buffer standard-output | ||
| 737 | (let ((class (cl-find-class type))) | ||
| 738 | (if class | ||
| 739 | (cl--describe-class type class) | ||
| 740 | ;; FIXME: Describe other types (the built-in ones, or those from | ||
| 741 | ;; cl-deftype). | ||
| 742 | (user-error "Unknown type %S" type)))) | ||
| 743 | (with-current-buffer standard-output | ||
| 744 | ;; Return the text we displayed. | ||
| 745 | (buffer-string))))) | ||
| 746 | |||
| 747 | (defun cl--describe-class (type &optional class) | ||
| 748 | (unless class (setq class (cl--find-class type))) | ||
| 749 | (let ((location (find-lisp-object-file-name type 'define-type)) | ||
| 750 | ;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch. | ||
| 751 | (metatype (cl--class-name (symbol-value (aref class 0))))) | ||
| 752 | (insert (symbol-name type) | ||
| 753 | (substitute-command-keys " is a type (of kind ‘")) | ||
| 754 | (help-insert-xref-button (symbol-name metatype) | ||
| 755 | 'cl-help-type metatype) | ||
| 756 | (insert (substitute-command-keys "’)")) | ||
| 757 | (when location | ||
| 758 | (insert (substitute-command-keys " in ‘")) | ||
| 759 | (help-insert-xref-button | ||
| 760 | (help-fns-short-filename location) | ||
| 761 | 'cl-type-definition type location 'define-type) | ||
| 762 | (insert (substitute-command-keys "’"))) | ||
| 763 | (insert ".\n") | ||
| 764 | |||
| 765 | ;; Parents. | ||
| 766 | (let ((pl (cl--class-parents class)) | ||
| 767 | cur) | ||
| 768 | (when pl | ||
| 769 | (insert " Inherits from ") | ||
| 770 | (while (setq cur (pop pl)) | ||
| 771 | (setq cur (cl--class-name cur)) | ||
| 772 | (insert (substitute-command-keys "‘")) | ||
| 773 | (help-insert-xref-button (symbol-name cur) | ||
| 774 | 'cl-help-type cur) | ||
| 775 | (insert (substitute-command-keys (if pl "’, " "’")))) | ||
| 776 | (insert ".\n"))) | ||
| 777 | |||
| 778 | ;; Children, if available. ¡For EIEIO! | ||
| 779 | (let ((ch (condition-case nil | ||
| 780 | (cl-struct-slot-value metatype 'children class) | ||
| 781 | (cl-struct-unknown-slot nil))) | ||
| 782 | cur) | ||
| 783 | (when ch | ||
| 784 | (insert " Children ") | ||
| 785 | (while (setq cur (pop ch)) | ||
| 786 | (insert (substitute-command-keys "‘")) | ||
| 787 | (help-insert-xref-button (symbol-name cur) | ||
| 788 | 'cl-help-type cur) | ||
| 789 | (insert (substitute-command-keys (if ch "’, " "’")))) | ||
| 790 | (insert ".\n"))) | ||
| 791 | |||
| 792 | ;; Type's documentation. | ||
| 793 | (let ((doc (cl--class-docstring class))) | ||
| 794 | (when doc | ||
| 795 | (insert "\n" doc "\n\n"))) | ||
| 796 | |||
| 797 | ;; Describe all the slots in this class. | ||
| 798 | (cl--describe-class-slots class) | ||
| 799 | |||
| 800 | ;; Describe all the methods specific to this class. | ||
| 801 | (let ((generics (cl--generic-all-functions type))) | ||
| 802 | (when generics | ||
| 803 | (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) | ||
| 804 | (dolist (generic generics) | ||
| 805 | (insert (substitute-command-keys "‘")) | ||
| 806 | (help-insert-xref-button (symbol-name generic) | ||
| 807 | 'help-function generic) | ||
| 808 | (insert (substitute-command-keys "’")) | ||
| 809 | (pcase-dolist (`(,qualifiers ,args ,doc) | ||
| 810 | (cl--generic-method-documentation generic type)) | ||
| 811 | (insert (format " %s%S\n" qualifiers args) | ||
| 812 | (or doc ""))) | ||
| 813 | (insert "\n\n")))))) | ||
| 814 | |||
| 815 | (defun cl--describe-class-slot (slot) | ||
| 816 | (insert | ||
| 817 | (concat | ||
| 818 | (propertize "Slot: " 'face 'bold) | ||
| 819 | (prin1-to-string (cl--slot-descriptor-name slot)) | ||
| 820 | (unless (eq (cl--slot-descriptor-type slot) t) | ||
| 821 | (concat " type = " | ||
| 822 | (prin1-to-string (cl--slot-descriptor-type slot)))) | ||
| 823 | ;; FIXME: The default init form is treated differently for structs and for | ||
| 824 | ;; eieio objects: for structs, the default is nil, for eieio-objects | ||
| 825 | ;; it's a special "unbound" value. | ||
| 826 | (unless nil ;; (eq (cl--slot-descriptor-initform slot) eieio-unbound) | ||
| 827 | (concat " default = " | ||
| 828 | (prin1-to-string (cl--slot-descriptor-initform slot)))) | ||
| 829 | (when (alist-get :printer (cl--slot-descriptor-props slot)) | ||
| 830 | (concat " printer = " | ||
| 831 | (prin1-to-string | ||
| 832 | (alist-get :printer (cl--slot-descriptor-props slot))))) | ||
| 833 | (when (alist-get :documentation (cl--slot-descriptor-props slot)) | ||
| 834 | (concat "\n " (alist-get :documentation (cl--slot-descriptor-props slot)) | ||
| 835 | "\n"))) | ||
| 836 | "\n")) | ||
| 837 | |||
| 838 | (defun cl--describe-class-slots (class) | ||
| 839 | "Print help description for the slots in CLASS. | ||
| 840 | Outputs to the current buffer." | ||
| 841 | (let* ((slots (cl--class-slots class)) | ||
| 842 | ;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch. | ||
| 843 | (metatype (cl--class-name (symbol-value (aref class 0)))) | ||
| 844 | ;; ¡For EIEIO! | ||
| 845 | (cslots (condition-case nil | ||
| 846 | (cl-struct-slot-value metatype 'class-slots class) | ||
| 847 | (cl-struct-unknown-slot nil)))) | ||
| 848 | (insert (propertize "Instance Allocated Slots:\n\n" | ||
| 849 | 'face 'bold)) | ||
| 850 | (mapc #'cl--describe-class-slot slots) | ||
| 851 | (when (> (length cslots) 0) | ||
| 852 | (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold)) | ||
| 853 | (mapc #'cl--describe-class-slot cslots)))) | ||
| 691 | 854 | ||
| 692 | 855 | ||
| 693 | (run-hooks 'cl-extra-load-hook) | 856 | (run-hooks 'cl-extra-load-hook) |
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 5923e4db996..a3bb7c3ad7b 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el | |||
| @@ -95,6 +95,7 @@ | |||
| 95 | ;; usually be simplified, or even completely skipped. | 95 | ;; usually be simplified, or even completely skipped. |
| 96 | 96 | ||
| 97 | (eval-when-compile (require 'cl-lib)) | 97 | (eval-when-compile (require 'cl-lib)) |
| 98 | (eval-when-compile (require 'cl-macs)) ;For cl--find-class. | ||
| 98 | (eval-when-compile (require 'pcase)) | 99 | (eval-when-compile (require 'pcase)) |
| 99 | 100 | ||
| 100 | (cl-defstruct (cl--generic-generalizer | 101 | (cl-defstruct (cl--generic-generalizer |
| @@ -883,6 +884,55 @@ Can only be used from within the lexical body of a primary or around method." | |||
| 883 | (insert (substitute-command-keys "’.\n")))) | 884 | (insert (substitute-command-keys "’.\n")))) |
| 884 | (insert "\n" (or (nth 2 info) "Undocumented") "\n\n"))))))) | 885 | (insert "\n" (or (nth 2 info) "Undocumented") "\n\n"))))))) |
| 885 | 886 | ||
| 887 | (defun cl--generic-specializers-apply-to-type-p (specializers type) | ||
| 888 | "Return non-nil if a method with SPECIALIZERS applies to TYPE." | ||
| 889 | (let ((applies nil)) | ||
| 890 | (dolist (specializer specializers) | ||
| 891 | (if (memq (car-safe specializer) '(subclass eieio--static)) | ||
| 892 | (setq specializer (nth 1 specializer))) | ||
| 893 | ;; Don't include the methods that are "too generic", such as those | ||
| 894 | ;; applying to `eieio-default-superclass'. | ||
| 895 | (and (not (memq specializer '(t eieio-default-superclass))) | ||
| 896 | (or (equal type specializer) | ||
| 897 | (when (symbolp specializer) | ||
| 898 | (let ((sclass (cl--find-class specializer)) | ||
| 899 | (tclass (cl--find-class type))) | ||
| 900 | (when (and sclass tclass) | ||
| 901 | (member specializer (cl--generic-class-parents tclass)))))) | ||
| 902 | (setq applies t))) | ||
| 903 | applies)) | ||
| 904 | |||
| 905 | (defun cl--generic-all-functions (&optional type) | ||
| 906 | "Return a list of all generic functions. | ||
| 907 | Optional TYPE argument returns only those functions that contain | ||
| 908 | methods for TYPE." | ||
| 909 | (let ((l nil)) | ||
| 910 | (mapatoms | ||
| 911 | (lambda (symbol) | ||
| 912 | (let ((generic (and (fboundp symbol) (cl--generic symbol)))) | ||
| 913 | (and generic | ||
| 914 | (catch 'found | ||
| 915 | (if (null type) (throw 'found t)) | ||
| 916 | (dolist (method (cl--generic-method-table generic)) | ||
| 917 | (if (cl--generic-specializers-apply-to-type-p | ||
| 918 | (cl--generic-method-specializers method) type) | ||
| 919 | (throw 'found t)))) | ||
| 920 | (push symbol l))))) | ||
| 921 | l)) | ||
| 922 | |||
| 923 | (defun cl--generic-method-documentation (function type) | ||
| 924 | "Return info for all methods of FUNCTION (a symbol) applicable to TYPE. | ||
| 925 | The value returned is a list of elements of the form | ||
| 926 | \(QUALIFIERS ARGS DOC)." | ||
| 927 | (let ((generic (cl--generic function)) | ||
| 928 | (docs ())) | ||
| 929 | (when generic | ||
| 930 | (dolist (method (cl--generic-method-table generic)) | ||
| 931 | (when (cl--generic-specializers-apply-to-type-p | ||
| 932 | (cl--generic-method-specializers method) type) | ||
| 933 | (push (cl--generic-method-info method) docs)))) | ||
| 934 | docs)) | ||
| 935 | |||
| 886 | ;;; Support for (head <val>) specializers. | 936 | ;;; Support for (head <val>) specializers. |
| 887 | 937 | ||
| 888 | ;; For both the `eql' and the `head' specializers, the dispatch | 938 | ;; For both the `eql' and the `head' specializers, the dispatch |
| @@ -958,19 +1008,22 @@ Can only be used from within the lexical body of a primary or around method." | |||
| 958 | (if (eq (symbol-function tag) :quick-object-witness-check) | 1008 | (if (eq (symbol-function tag) :quick-object-witness-check) |
| 959 | tag)))) | 1009 | tag)))) |
| 960 | 1010 | ||
| 1011 | (defun cl--generic-class-parents (class) | ||
| 1012 | (let ((parents ()) | ||
| 1013 | (classes (list class))) | ||
| 1014 | ;; BFS precedence. FIXME: Use a topological sort. | ||
| 1015 | (while (let ((class (pop classes))) | ||
| 1016 | (cl-pushnew (cl--class-name class) parents) | ||
| 1017 | (setq classes | ||
| 1018 | (append classes | ||
| 1019 | (cl--class-parents class))))) | ||
| 1020 | (nreverse parents))) | ||
| 1021 | |||
| 961 | (defun cl--generic-struct-specializers (tag) | 1022 | (defun cl--generic-struct-specializers (tag) |
| 962 | (and (symbolp tag) (boundp tag) | 1023 | (and (symbolp tag) (boundp tag) |
| 963 | (let ((class (symbol-value tag))) | 1024 | (let ((class (symbol-value tag))) |
| 964 | (when (cl-typep class 'cl-structure-class) | 1025 | (when (cl-typep class 'cl-structure-class) |
| 965 | (let ((types ()) | 1026 | (cl--generic-class-parents class))))) |
| 966 | (classes (list class))) | ||
| 967 | ;; BFS precedence. | ||
| 968 | (while (let ((class (pop classes))) | ||
| 969 | (push (cl--class-name class) types) | ||
| 970 | (setq classes | ||
| 971 | (append classes | ||
| 972 | (cl--class-parents class))))) | ||
| 973 | (nreverse types)))))) | ||
| 974 | 1027 | ||
| 975 | (defconst cl--generic-struct-generalizer | 1028 | (defconst cl--generic-struct-generalizer |
| 976 | (cl-generic-make-generalizer | 1029 | (cl-generic-make-generalizer |
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 5bcf0882791..f5e1ffb0008 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el | |||
| @@ -2722,20 +2722,16 @@ non-nil value, that slot cannot be set via `setf'. | |||
| 2722 | (push `(defalias ',copier #'copy-sequence) forms)) | 2722 | (push `(defalias ',copier #'copy-sequence) forms)) |
| 2723 | (if constructor | 2723 | (if constructor |
| 2724 | (push (list constructor | 2724 | (push (list constructor |
| 2725 | (cons '&key (delq nil (copy-sequence slots)))) | 2725 | (cons '&key (delq nil (copy-sequence slots)))) |
| 2726 | constrs)) | 2726 | constrs)) |
| 2727 | (while constrs | 2727 | (pcase-dolist (`(,cname ,args ,doc) constrs) |
| 2728 | (let* ((name (caar constrs)) | 2728 | (let* ((anames (cl--arglist-args args)) |
| 2729 | (rest (cdr (pop constrs))) | ||
| 2730 | (args (car rest)) | ||
| 2731 | (doc (cadr rest)) | ||
| 2732 | (anames (cl--arglist-args args)) | ||
| 2733 | (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) | 2729 | (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) |
| 2734 | slots defaults))) | 2730 | slots defaults))) |
| 2735 | (push `(cl-defsubst ,name | 2731 | (push `(cl-defsubst ,cname |
| 2736 | (&cl-defs (nil ,@descs) ,@args) | 2732 | (&cl-defs (nil ,@descs) ,@args) |
| 2737 | ,@(if (stringp doc) (list doc) | 2733 | ,(if (stringp doc) (list doc) |
| 2738 | (if (stringp docstring) (list docstring))) | 2734 | (format "Constructor for objects of type `%s'." name)) |
| 2739 | ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) | 2735 | ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) |
| 2740 | '((declare (side-effect-free t)))) | 2736 | '((declare (side-effect-free t)))) |
| 2741 | (,(or type #'vector) ,@make)) | 2737 | (,(or type #'vector) ,@make)) |
| @@ -2859,6 +2855,8 @@ slots skipped by :initial-offset may appear in the list." | |||
| 2859 | descs))) | 2855 | descs))) |
| 2860 | (nreverse descs))) | 2856 | (nreverse descs))) |
| 2861 | 2857 | ||
| 2858 | (define-error 'cl-struct-unknown-slot "struct %S has no slot %S") | ||
| 2859 | |||
| 2862 | (defun cl-struct-slot-offset (struct-type slot-name) | 2860 | (defun cl-struct-slot-offset (struct-type slot-name) |
| 2863 | "Return the offset of slot SLOT-NAME in STRUCT-TYPE. | 2861 | "Return the offset of slot SLOT-NAME in STRUCT-TYPE. |
| 2864 | The returned zero-based slot index is relative to the start of | 2862 | The returned zero-based slot index is relative to the start of |
| @@ -2868,7 +2866,7 @@ does not contain SLOT-NAME." | |||
| 2868 | (declare (side-effect-free t) (pure t)) | 2866 | (declare (side-effect-free t) (pure t)) |
| 2869 | (or (gethash slot-name | 2867 | (or (gethash slot-name |
| 2870 | (cl--class-index-table (cl--struct-get-class struct-type))) | 2868 | (cl--class-index-table (cl--struct-get-class struct-type))) |
| 2871 | (error "struct %s has no slot %s" struct-type slot-name))) | 2869 | (signal 'cl-struct-unknown-slot (list struct-type slot-name)))) |
| 2872 | 2870 | ||
| 2873 | (defvar byte-compile-function-environment) | 2871 | (defvar byte-compile-function-environment) |
| 2874 | (defvar byte-compile-macro-environment) | 2872 | (defvar byte-compile-macro-environment) |
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 60f654258b0..03480b2756b 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el | |||
| @@ -147,6 +147,7 @@ | |||
| 147 | ok) | 147 | ok) |
| 148 | (error "Included struct %S has changed since compilation of %S" | 148 | (error "Included struct %S has changed since compilation of %S" |
| 149 | parent name)))) | 149 | parent name)))) |
| 150 | (add-to-list 'current-load-list `(define-type . ,name)) | ||
| 150 | (cl--struct-register-child parent-class tag) | 151 | (cl--struct-register-child parent-class tag) |
| 151 | (unless (eq named t) | 152 | (unless (eq named t) |
| 152 | (eval `(defconst ,tag ',class) t) | 153 | (eval `(defconst ,tag ',class) t) |
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 8a09f071e2e..7fcf85c1ced 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el | |||
| @@ -261,6 +261,8 @@ It creates an autoload function for CNAME's constructor." | |||
| 261 | (and (eieio-object-p obj) | 261 | (and (eieio-object-p obj) |
| 262 | (object-of-class-p obj class)))) | 262 | (object-of-class-p obj class)))) |
| 263 | 263 | ||
| 264 | (defvar eieio--known-slot-names nil) | ||
| 265 | |||
| 264 | (defun eieio-defclass-internal (cname superclasses slots options) | 266 | (defun eieio-defclass-internal (cname superclasses slots options) |
| 265 | "Define CNAME as a new subclass of SUPERCLASSES. | 267 | "Define CNAME as a new subclass of SUPERCLASSES. |
| 266 | SLOTS are the slots residing in that class definition, and OPTIONS | 268 | SLOTS are the slots residing in that class definition, and OPTIONS |
| @@ -473,7 +475,7 @@ See `defclass' for more information." | |||
| 473 | (put cname 'variable-documentation docstring))) | 475 | (put cname 'variable-documentation docstring))) |
| 474 | 476 | ||
| 475 | ;; Save the file location where this class is defined. | 477 | ;; Save the file location where this class is defined. |
| 476 | (add-to-list 'current-load-list `(eieio-defclass . ,cname)) | 478 | (add-to-list 'current-load-list `(define-type . ,cname)) |
| 477 | 479 | ||
| 478 | ;; We have a list of custom groups. Store them into the options. | 480 | ;; We have a list of custom groups. Store them into the options. |
| 479 | (let ((g (eieio--class-option-assoc options :custom-groups))) | 481 | (let ((g (eieio--class-option-assoc options :custom-groups))) |
| @@ -603,47 +605,48 @@ if default value is nil." | |||
| 603 | :key #'cl--slot-descriptor-name))) | 605 | :key #'cl--slot-descriptor-name))) |
| 604 | (cold (car (cl-member a (eieio--class-class-slots newc) | 606 | (cold (car (cl-member a (eieio--class-class-slots newc) |
| 605 | :key #'cl--slot-descriptor-name)))) | 607 | :key #'cl--slot-descriptor-name)))) |
| 606 | (condition-case nil | 608 | (cl-pushnew a eieio--known-slot-names) |
| 607 | (if (sequencep d) (setq d (copy-sequence d))) | 609 | (condition-case nil |
| 608 | ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's | 610 | (if (sequencep d) (setq d (copy-sequence d))) |
| 609 | ;; skip it if it doesn't work. | 611 | ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's |
| 610 | (error nil)) | 612 | ;; skip it if it doesn't work. |
| 611 | ;; (if (sequencep type) (setq type (copy-sequence type))) | 613 | (error nil)) |
| 612 | ;; (if (sequencep cust) (setq cust (copy-sequence cust))) | 614 | ;; (if (sequencep type) (setq type (copy-sequence type))) |
| 613 | ;; (if (sequencep custg) (setq custg (copy-sequence custg))) | 615 | ;; (if (sequencep cust) (setq cust (copy-sequence cust))) |
| 614 | 616 | ;; (if (sequencep custg) (setq custg (copy-sequence custg))) | |
| 615 | ;; To prevent override information w/out specification of storage, | 617 | |
| 616 | ;; we need to do this little hack. | 618 | ;; To prevent override information w/out specification of storage, |
| 617 | (if cold (setq alloc :class)) | 619 | ;; we need to do this little hack. |
| 618 | 620 | (if cold (setq alloc :class)) | |
| 619 | (if (memq alloc '(nil :instance)) | 621 | |
| 620 | ;; In this case, we modify the INSTANCE version of a given slot. | 622 | (if (memq alloc '(nil :instance)) |
| 621 | (progn | 623 | ;; In this case, we modify the INSTANCE version of a given slot. |
| 622 | ;; Only add this element if it is so-far unique | ||
| 623 | (if (not old) | ||
| 624 | (progn | ||
| 625 | (eieio--perform-slot-validation-for-default slot skipnil) | ||
| 626 | (push slot (eieio--class-slots newc)) | ||
| 627 | ) | ||
| 628 | ;; When defaultoverride is true, we are usually adding new local | ||
| 629 | ;; attributes which must override the default value of any slot | ||
| 630 | ;; passed in by one of the parent classes. | ||
| 631 | (when defaultoverride | ||
| 632 | (eieio--slot-override old slot skipnil))) | ||
| 633 | (when init | ||
| 634 | (cl-pushnew (cons init a) (eieio--class-initarg-tuples newc) | ||
| 635 | :test #'equal))) | ||
| 636 | |||
| 637 | ;; CLASS ALLOCATED SLOTS | ||
| 638 | (if (not cold) | ||
| 639 | (progn | 624 | (progn |
| 640 | (eieio--perform-slot-validation-for-default slot skipnil) | 625 | ;; Only add this element if it is so-far unique |
| 641 | ;; Here we have found a :class version of a slot. This | 626 | (if (not old) |
| 642 | ;; requires a very different approach. | 627 | (progn |
| 643 | (push slot (eieio--class-class-slots newc))) | 628 | (eieio--perform-slot-validation-for-default slot skipnil) |
| 644 | (when defaultoverride | 629 | (push slot (eieio--class-slots newc)) |
| 645 | ;; There is a match, and we must override the old value. | 630 | ) |
| 646 | (eieio--slot-override cold slot skipnil)))))) | 631 | ;; When defaultoverride is true, we are usually adding new local |
| 632 | ;; attributes which must override the default value of any slot | ||
| 633 | ;; passed in by one of the parent classes. | ||
| 634 | (when defaultoverride | ||
| 635 | (eieio--slot-override old slot skipnil))) | ||
| 636 | (when init | ||
| 637 | (cl-pushnew (cons init a) (eieio--class-initarg-tuples newc) | ||
| 638 | :test #'equal))) | ||
| 639 | |||
| 640 | ;; CLASS ALLOCATED SLOTS | ||
| 641 | (if (not cold) | ||
| 642 | (progn | ||
| 643 | (eieio--perform-slot-validation-for-default slot skipnil) | ||
| 644 | ;; Here we have found a :class version of a slot. This | ||
| 645 | ;; requires a very different approach. | ||
| 646 | (push slot (eieio--class-class-slots newc))) | ||
| 647 | (when defaultoverride | ||
| 648 | ;; There is a match, and we must override the old value. | ||
| 649 | (eieio--slot-override cold slot skipnil)))))) | ||
| 647 | 650 | ||
| 648 | (defun eieio-copy-parents-into-subclass (newc) | 651 | (defun eieio-copy-parents-into-subclass (newc) |
| 649 | "Copy into NEWC the slots of PARENTS. | 652 | "Copy into NEWC the slots of PARENTS. |
| @@ -720,9 +723,18 @@ Argument FN is the function calling this verifier." | |||
| 720 | 723 | ||
| 721 | 724 | ||
| 722 | ;;; Get/Set slots in an object. | 725 | ;;; Get/Set slots in an object. |
| 723 | ;; | 726 | |
| 724 | (defun eieio-oref (obj slot) | 727 | (defun eieio-oref (obj slot) |
| 725 | "Return the value in OBJ at SLOT in the object vector." | 728 | "Return the value in OBJ at SLOT in the object vector." |
| 729 | (declare (compiler-macro | ||
| 730 | (lambda (exp) | ||
| 731 | (ignore obj) | ||
| 732 | (pcase slot | ||
| 733 | ((and (or `',name (and name (pred keywordp))) | ||
| 734 | (guard (not (memq name eieio--known-slot-names)))) | ||
| 735 | (macroexp--warn-and-return | ||
| 736 | (format "Unknown slot `%S'" name) exp 'compile-only)) | ||
| 737 | (_ exp))))) | ||
| 726 | (cl-check-type slot symbol) | 738 | (cl-check-type slot symbol) |
| 727 | (cl-check-type obj (or eieio-object class)) | 739 | (cl-check-type obj (or eieio-object class)) |
| 728 | (let* ((class (cond ((symbolp obj) | 740 | (let* ((class (cond ((symbolp obj) |
diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index f7dbdf5014b..9ecc59434e1 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el | |||
| @@ -31,7 +31,6 @@ | |||
| 31 | (require 'eieio) | 31 | (require 'eieio) |
| 32 | (require 'find-func) | 32 | (require 'find-func) |
| 33 | (require 'speedbar) | 33 | (require 'speedbar) |
| 34 | (require 'help-mode) | ||
| 35 | 34 | ||
| 36 | ;;; Code: | 35 | ;;; Code: |
| 37 | ;;;###autoload | 36 | ;;;###autoload |
| @@ -78,101 +77,7 @@ Argument CH-PREFIX is another character prefix to display." | |||
| 78 | (declare-function help-fns-short-filename "help-fns" (filename)) | 77 | (declare-function help-fns-short-filename "help-fns" (filename)) |
| 79 | 78 | ||
| 80 | ;;;###autoload | 79 | ;;;###autoload |
| 81 | (defun eieio-help-class (class) | 80 | (define-obsolete-function-alias 'eieio-help-class 'cl--describe-class "25.1") |
| 82 | "Print help description for CLASS. | ||
| 83 | If CLASS is actually an object, then also display current values of that object." | ||
| 84 | ;; Header line | ||
| 85 | (prin1 class) | ||
| 86 | (insert " is a" | ||
| 87 | (if (eieio--class-option (cl--find-class class) :abstract) | ||
| 88 | "n abstract" | ||
| 89 | "") | ||
| 90 | " class") | ||
| 91 | (let ((location (find-lisp-object-file-name class 'eieio-defclass))) | ||
| 92 | (when location | ||
| 93 | (insert (substitute-command-keys " in ‘")) | ||
| 94 | (help-insert-xref-button | ||
| 95 | (help-fns-short-filename location) | ||
| 96 | 'eieio-class-def class location 'eieio-defclass) | ||
| 97 | (insert (substitute-command-keys "’")))) | ||
| 98 | (insert ".\n") | ||
| 99 | ;; Parents | ||
| 100 | (let ((pl (eieio-class-parents class)) | ||
| 101 | cur) | ||
| 102 | (when pl | ||
| 103 | (insert " Inherits from ") | ||
| 104 | (while (setq cur (pop pl)) | ||
| 105 | (setq cur (eieio--class-name cur)) | ||
| 106 | (insert (substitute-command-keys "‘")) | ||
| 107 | (help-insert-xref-button (symbol-name cur) | ||
| 108 | 'help-function cur) | ||
| 109 | (insert (substitute-command-keys (if pl "’, " "’")))) | ||
| 110 | (insert ".\n"))) | ||
| 111 | ;; Children | ||
| 112 | (let ((ch (eieio-class-children class)) | ||
| 113 | cur) | ||
| 114 | (when ch | ||
| 115 | (insert " Children ") | ||
| 116 | (while (setq cur (pop ch)) | ||
| 117 | (insert (substitute-command-keys "‘")) | ||
| 118 | (help-insert-xref-button (symbol-name cur) | ||
| 119 | 'help-function cur) | ||
| 120 | (insert (substitute-command-keys (if ch "’, " "’")))) | ||
| 121 | (insert ".\n"))) | ||
| 122 | ;; System documentation | ||
| 123 | (let ((doc (documentation-property class 'variable-documentation))) | ||
| 124 | (when doc | ||
| 125 | (insert "\n" doc "\n\n"))) | ||
| 126 | ;; Describe all the slots in this class. | ||
| 127 | (eieio-help-class-slots class) | ||
| 128 | ;; Describe all the methods specific to this class. | ||
| 129 | (let ((generics (eieio-all-generic-functions class))) | ||
| 130 | (when generics | ||
| 131 | (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) | ||
| 132 | (dolist (generic generics) | ||
| 133 | (insert (substitute-command-keys "‘")) | ||
| 134 | (help-insert-xref-button (symbol-name generic) 'help-function generic) | ||
| 135 | (insert (substitute-command-keys "’")) | ||
| 136 | (pcase-dolist (`(,qualifiers ,args ,doc) | ||
| 137 | (eieio-method-documentation generic class)) | ||
| 138 | (insert (format " %s%S\n" qualifiers args) | ||
| 139 | (or doc ""))) | ||
| 140 | (insert "\n\n"))))) | ||
| 141 | |||
| 142 | (defun eieio--help-print-slot (slot) | ||
| 143 | (insert | ||
| 144 | (concat | ||
| 145 | (propertize "Slot: " 'face 'bold) | ||
| 146 | (prin1-to-string (cl--slot-descriptor-name slot)) | ||
| 147 | (unless (eq (cl--slot-descriptor-type slot) t) | ||
| 148 | (concat " type = " | ||
| 149 | (prin1-to-string (cl--slot-descriptor-type slot)))) | ||
| 150 | (unless (eq (cl--slot-descriptor-initform slot) eieio-unbound) | ||
| 151 | (concat " default = " | ||
| 152 | (prin1-to-string (cl--slot-descriptor-initform slot)))) | ||
| 153 | (when (alist-get :printer (cl--slot-descriptor-props slot)) | ||
| 154 | (concat " printer = " | ||
| 155 | (prin1-to-string | ||
| 156 | (alist-get :printer (cl--slot-descriptor-props slot))))) | ||
| 157 | (when (alist-get :documentation (cl--slot-descriptor-props slot)) | ||
| 158 | (concat "\n " (alist-get :documentation (cl--slot-descriptor-props slot)) | ||
| 159 | "\n"))) | ||
| 160 | "\n")) | ||
| 161 | |||
| 162 | (defun eieio-help-class-slots (class) | ||
| 163 | "Print help description for the slots in CLASS. | ||
| 164 | Outputs to the current buffer." | ||
| 165 | (let* ((cv (cl--find-class class)) | ||
| 166 | (slots (eieio--class-slots cv)) | ||
| 167 | (cslots (eieio--class-class-slots cv))) | ||
| 168 | (insert (propertize "Instance Allocated Slots:\n\n" | ||
| 169 | 'face 'bold)) | ||
| 170 | (dotimes (i (length slots)) | ||
| 171 | (eieio--help-print-slot (aref slots i))) | ||
| 172 | (when (> (length cslots) 0) | ||
| 173 | (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold))) | ||
| 174 | (dotimes (i (length cslots)) | ||
| 175 | (eieio--help-print-slot (aref cslots i))))) | ||
| 176 | 81 | ||
| 177 | (defun eieio-build-class-alist (&optional class instantiable-only buildlist) | 82 | (defun eieio-build-class-alist (&optional class instantiable-only buildlist) |
| 178 | "Return an alist of all currently active classes for completion purposes. | 83 | "Return an alist of all currently active classes for completion purposes. |
| @@ -217,22 +122,13 @@ are not abstract." | |||
| 217 | 122 | ||
| 218 | ;;; METHOD COMPLETION / DOC | 123 | ;;; METHOD COMPLETION / DOC |
| 219 | 124 | ||
| 220 | (define-button-type 'eieio-class-def | ||
| 221 | :supertype 'help-function-def | ||
| 222 | 'help-echo (purecopy "mouse-2, RET: find class definition")) | ||
| 223 | |||
| 224 | (defconst eieio--defclass-regexp "(defclass[ \t\r\n]+%s[ \t\r\n]+") | ||
| 225 | (with-eval-after-load 'find-func | ||
| 226 | (defvar find-function-regexp-alist) | ||
| 227 | (add-to-list 'find-function-regexp-alist | ||
| 228 | `(eieio-defclass . eieio--defclass-regexp))) | ||
| 229 | 125 | ||
| 230 | ;;;###autoload | 126 | ;;;###autoload |
| 231 | (defun eieio-help-constructor (ctr) | 127 | (defun eieio-help-constructor (ctr) |
| 232 | "Describe CTR if it is a class constructor." | 128 | "Describe CTR if it is a class constructor." |
| 233 | (when (class-p ctr) | 129 | (when (class-p ctr) |
| 234 | (erase-buffer) | 130 | (erase-buffer) |
| 235 | (let ((location (find-lisp-object-file-name ctr 'eieio-defclass)) | 131 | (let ((location (find-lisp-object-file-name ctr 'define-type)) |
| 236 | (def (symbol-function ctr))) | 132 | (def (symbol-function ctr))) |
| 237 | (goto-char (point-min)) | 133 | (goto-char (point-min)) |
| 238 | (prin1 ctr) | 134 | (prin1 ctr) |
| @@ -248,7 +144,7 @@ are not abstract." | |||
| 248 | (insert (substitute-command-keys " in ‘")) | 144 | (insert (substitute-command-keys " in ‘")) |
| 249 | (help-insert-xref-button | 145 | (help-insert-xref-button |
| 250 | (help-fns-short-filename location) | 146 | (help-fns-short-filename location) |
| 251 | 'eieio-class-def ctr location 'eieio-defclass) | 147 | 'cl-type-definition ctr location 'define-type) |
| 252 | (insert (substitute-command-keys "’"))) | 148 | (insert (substitute-command-keys "’"))) |
| 253 | (insert ".\nCreates an object of class " (symbol-name ctr) ".") | 149 | (insert ".\nCreates an object of class " (symbol-name ctr) ".") |
| 254 | (goto-char (point-max)) | 150 | (goto-char (point-max)) |
| @@ -259,50 +155,6 @@ are not abstract." | |||
| 259 | (eieio-help-class ctr)) | 155 | (eieio-help-class ctr)) |
| 260 | )))) | 156 | )))) |
| 261 | 157 | ||
| 262 | (defun eieio--specializers-apply-to-class-p (specializers class) | ||
| 263 | "Return non-nil if a method with SPECIALIZERS applies to CLASS." | ||
| 264 | (let ((applies nil)) | ||
| 265 | (dolist (specializer specializers) | ||
| 266 | (if (memq (car-safe specializer) '(subclass eieio--static)) | ||
| 267 | (setq specializer (nth 1 specializer))) | ||
| 268 | ;; Don't include the methods that are "too generic", such as those | ||
| 269 | ;; applying to `eieio-default-superclass'. | ||
| 270 | (and (not (memq specializer '(t eieio-default-superclass))) | ||
| 271 | (class-p specializer) | ||
| 272 | (child-of-class-p class specializer) | ||
| 273 | (setq applies t))) | ||
| 274 | applies)) | ||
| 275 | |||
| 276 | (defun eieio-all-generic-functions (&optional class) | ||
| 277 | "Return a list of all generic functions. | ||
| 278 | Optional CLASS argument returns only those functions that contain | ||
| 279 | methods for CLASS." | ||
| 280 | (let ((l nil)) | ||
| 281 | (mapatoms | ||
| 282 | (lambda (symbol) | ||
| 283 | (let ((generic (and (fboundp symbol) (cl--generic symbol)))) | ||
| 284 | (and generic | ||
| 285 | (catch 'found | ||
| 286 | (if (null class) (throw 'found t)) | ||
| 287 | (dolist (method (cl--generic-method-table generic)) | ||
| 288 | (if (eieio--specializers-apply-to-class-p | ||
| 289 | (cl--generic-method-specializers method) class) | ||
| 290 | (throw 'found t)))) | ||
| 291 | (push symbol l))))) | ||
| 292 | l)) | ||
| 293 | |||
| 294 | (defun eieio-method-documentation (generic class) | ||
| 295 | "Return info for all methods of GENERIC applicable to CLASS. | ||
| 296 | The value returned is a list of elements of the form | ||
| 297 | \(QUALIFIERS ARGS DOC)." | ||
| 298 | (let ((generic (cl--generic generic)) | ||
| 299 | (docs ())) | ||
| 300 | (when generic | ||
| 301 | (dolist (method (cl--generic-method-table generic)) | ||
| 302 | (when (eieio--specializers-apply-to-class-p | ||
| 303 | (cl--generic-method-specializers method) class) | ||
| 304 | (push (cl--generic-method-info method) docs)))) | ||
| 305 | docs)) | ||
| 306 | 158 | ||
| 307 | ;;; METHOD STATS | 159 | ;;; METHOD STATS |
| 308 | ;; | 160 | ;; |
| @@ -310,7 +162,7 @@ The value returned is a list of elements of the form | |||
| 310 | (defun eieio-display-method-list () | 162 | (defun eieio-display-method-list () |
| 311 | "Display a list of all the methods and what features are used." | 163 | "Display a list of all the methods and what features are used." |
| 312 | (interactive) | 164 | (interactive) |
| 313 | (let* ((meth1 (eieio-all-generic-functions)) | 165 | (let* ((meth1 (cl--generic-all-functions)) |
| 314 | (meth (sort meth1 (lambda (a b) | 166 | (meth (sort meth1 (lambda (a b) |
| 315 | (string< (symbol-name a) | 167 | (string< (symbol-name a) |
| 316 | (symbol-name b))))) | 168 | (symbol-name b))))) |
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index eee848f7869..84a68a83736 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el | |||
| @@ -142,6 +142,10 @@ and reference them using the function `class-option'." | |||
| 142 | (alloc (plist-get soptions :allocation)) | 142 | (alloc (plist-get soptions :allocation)) |
| 143 | (label (plist-get soptions :label))) | 143 | (label (plist-get soptions :label))) |
| 144 | 144 | ||
| 145 | ;; Update eieio--known-slot-names already in case we compile code which | ||
| 146 | ;; uses this before the class is loaded. | ||
| 147 | (cl-pushnew sname eieio--known-slot-names) | ||
| 148 | |||
| 145 | (if eieio-error-unsupported-class-tags | 149 | (if eieio-error-unsupported-class-tags |
| 146 | (let ((tmp soptions)) | 150 | (let ((tmp soptions)) |
| 147 | (while tmp | 151 | (while tmp |
| @@ -254,13 +258,12 @@ This method is obsolete." | |||
| 254 | (if (not (stringp abs)) | 258 | (if (not (stringp abs)) |
| 255 | (setq abs (format "Class %s is abstract" name))) | 259 | (setq abs (format "Class %s is abstract" name))) |
| 256 | `(defun ,name (&rest _) | 260 | `(defun ,name (&rest _) |
| 257 | ,(format "You cannot create a new object of type %S." name) | 261 | ,(format "You cannot create a new object of type `%S'." name) |
| 258 | (error ,abs))) | 262 | (error ,abs))) |
| 259 | 263 | ||
| 260 | ;; Non-abstract classes need a constructor. | 264 | ;; Non-abstract classes need a constructor. |
| 261 | `(defun ,name (&rest slots) | 265 | `(defun ,name (&rest slots) |
| 262 | ,(format "Create a new object with name NAME of class type %S." | 266 | ,(format "Create a new object of class type `%S'." name) |
| 263 | name) | ||
| 264 | (declare (compiler-macro | 267 | (declare (compiler-macro |
| 265 | (lambda (whole) | 268 | (lambda (whole) |
| 266 | (if (not (stringp (car slots))) | 269 | (if (not (stringp (car slots))) |
| @@ -941,6 +944,8 @@ of `eq'." | |||
| 941 | (error "EIEIO: `change-class' is unimplemented")) | 944 | (error "EIEIO: `change-class' is unimplemented")) |
| 942 | 945 | ||
| 943 | ;; Hook ourselves into help system for describing classes and methods. | 946 | ;; Hook ourselves into help system for describing classes and methods. |
| 947 | ;; FIXME: This is not actually needed any more since we can click on the | ||
| 948 | ;; hyperlink from the constructor's docstring to see the type definition. | ||
| 944 | (add-hook 'help-fns-describe-function-functions 'eieio-help-constructor) | 949 | (add-hook 'help-fns-describe-function-functions 'eieio-help-constructor) |
| 945 | 950 | ||
| 946 | ;;; Interfacing with edebug | 951 | ;;; Interfacing with edebug |
| @@ -978,7 +983,7 @@ Optional argument GROUP is the sub-group of slots to display. | |||
| 978 | 983 | ||
| 979 | ;;;*** | 984 | ;;;*** |
| 980 | 985 | ||
| 981 | ;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "b7995d9076e4dd4b9358b2aa66835619") | 986 | ;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "cb1aba7670b6a4b9c6f968c0ad6dc130") |
| 982 | ;;; Generated autoloads from eieio-opt.el | 987 | ;;; Generated autoloads from eieio-opt.el |
| 983 | 988 | ||
| 984 | (autoload 'eieio-browse "eieio-opt" "\ | 989 | (autoload 'eieio-browse "eieio-opt" "\ |
| @@ -988,11 +993,7 @@ variable `eieio-default-superclass'. | |||
| 988 | 993 | ||
| 989 | \(fn &optional ROOT-CLASS)" t nil) | 994 | \(fn &optional ROOT-CLASS)" t nil) |
| 990 | 995 | ||
| 991 | (autoload 'eieio-help-class "eieio-opt" "\ | 996 | (define-obsolete-function-alias 'eieio-help-class 'cl--describe-class "25.1") |
| 992 | Print help description for CLASS. | ||
| 993 | If CLASS is actually an object, then also display current values of that object. | ||
| 994 | |||
| 995 | \(fn CLASS)" nil nil) | ||
| 996 | 997 | ||
| 997 | (autoload 'eieio-help-constructor "eieio-opt" "\ | 998 | (autoload 'eieio-help-constructor "eieio-opt" "\ |
| 998 | Describe CTR if it is a class constructor. | 999 | Describe CTR if it is a class constructor. |
diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 72a23cfdfc6..8aa34c7bef9 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el | |||
| @@ -95,7 +95,7 @@ | |||
| 95 | (regexp-opt | 95 | (regexp-opt |
| 96 | '("defun" "defmacro" | 96 | '("defun" "defmacro" |
| 97 | ;; Elisp. | 97 | ;; Elisp. |
| 98 | "defun*" "defsubst" | 98 | "defun*" "defsubst" "define-inline" |
| 99 | "define-advice" "defadvice" "define-skeleton" | 99 | "define-advice" "defadvice" "define-skeleton" |
| 100 | "define-compilation-mode" "define-minor-mode" | 100 | "define-compilation-mode" "define-minor-mode" |
| 101 | "define-global-minor-mode" | 101 | "define-global-minor-mode" |
| @@ -230,7 +230,7 @@ | |||
| 230 | (throw 'found t)))))) | 230 | (throw 'found t)))))) |
| 231 | 231 | ||
| 232 | (let-when-compile | 232 | (let-when-compile |
| 233 | ((lisp-fdefs '("defmacro" "defsubst" "defun")) | 233 | ((lisp-fdefs '("defmacro" "defun")) |
| 234 | (lisp-vdefs '("defvar")) | 234 | (lisp-vdefs '("defvar")) |
| 235 | (lisp-kw '("cond" "if" "while" "let" "let*" "progn" "prog1" | 235 | (lisp-kw '("cond" "if" "while" "let" "let*" "progn" "prog1" |
| 236 | "prog2" "lambda" "unwind-protect" "condition-case" | 236 | "prog2" "lambda" "unwind-protect" "condition-case" |
| @@ -240,7 +240,8 @@ | |||
| 240 | ;; Elisp constructs. Now they are update dynamically | 240 | ;; Elisp constructs. Now they are update dynamically |
| 241 | ;; from obarray but they are also used for setting up | 241 | ;; from obarray but they are also used for setting up |
| 242 | ;; the keywords for Common Lisp. | 242 | ;; the keywords for Common Lisp. |
| 243 | (el-fdefs '("define-advice" "defadvice" "defalias" | 243 | (el-fdefs '("defsubst" "cl-defsubst" "define-inline" |
| 244 | "define-advice" "defadvice" "defalias" | ||
| 244 | "define-derived-mode" "define-minor-mode" | 245 | "define-derived-mode" "define-minor-mode" |
| 245 | "define-generic-mode" "define-global-minor-mode" | 246 | "define-generic-mode" "define-global-minor-mode" |
| 246 | "define-globalized-minor-mode" "define-skeleton" | 247 | "define-globalized-minor-mode" "define-skeleton" |
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 57cbec580b0..ffc6585e191 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el | |||
| @@ -119,20 +119,28 @@ and also to avoid outputting the warning during normal execution." | |||
| 119 | (member '(declare-function . byte-compile-macroexpand-declare-function) | 119 | (member '(declare-function . byte-compile-macroexpand-declare-function) |
| 120 | macroexpand-all-environment)) | 120 | macroexpand-all-environment)) |
| 121 | 121 | ||
| 122 | (defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key)) | ||
| 122 | 123 | ||
| 123 | (defun macroexp--warn-and-return (msg form) | 124 | (defun macroexp--warn-and-return (msg form &optional compile-only) |
| 124 | (let ((when-compiled (lambda () (byte-compile-log-warning msg t)))) | 125 | (let ((when-compiled (lambda () (byte-compile-log-warning msg t)))) |
| 125 | (cond | 126 | (cond |
| 126 | ((null msg) form) | 127 | ((null msg) form) |
| 127 | ((macroexp--compiling-p) | 128 | ((macroexp--compiling-p) |
| 128 | `(progn | 129 | (if (gethash form macroexp--warned) |
| 129 | (macroexp--funcall-if-compiled ',when-compiled) | 130 | ;; Already wrapped this exp with a warning: avoid inf-looping |
| 130 | ,form)) | 131 | ;; where we keep adding the same warning onto `form' because |
| 132 | ;; macroexpand-all gets right back to macroexpanding `form'. | ||
| 133 | form | ||
| 134 | (puthash form form macroexp--warned) | ||
| 135 | `(progn | ||
| 136 | (macroexp--funcall-if-compiled ',when-compiled) | ||
| 137 | ,form))) | ||
| 131 | (t | 138 | (t |
| 132 | (message "%s%s" (if (stringp load-file-name) | 139 | (unless compile-only |
| 133 | (concat (file-relative-name load-file-name) ": ") | 140 | (message "%s%s" (if (stringp load-file-name) |
| 134 | "") | 141 | (concat (file-relative-name load-file-name) ": ") |
| 135 | msg) | 142 | "") |
| 143 | msg)) | ||
| 136 | form)))) | 144 | form)))) |
| 137 | 145 | ||
| 138 | (defun macroexp--obsolete-warning (fun obsolescence-data type) | 146 | (defun macroexp--obsolete-warning (fun obsolescence-data type) |
| @@ -208,30 +216,30 @@ Assumes the caller has bound `macroexpand-all-environment'." | |||
| 208 | (macroexp--cons | 216 | (macroexp--cons |
| 209 | 'condition-case | 217 | 'condition-case |
| 210 | (macroexp--cons err | 218 | (macroexp--cons err |
| 211 | (macroexp--cons (macroexp--expand-all body) | 219 | (macroexp--cons (macroexp--expand-all body) |
| 212 | (macroexp--all-clauses handlers 1) | 220 | (macroexp--all-clauses handlers 1) |
| 213 | (cddr form)) | 221 | (cddr form)) |
| 214 | (cdr form)) | 222 | (cdr form)) |
| 215 | form)) | 223 | form)) |
| 216 | (`(,(or `defvar `defconst) . ,_) (macroexp--all-forms form 2)) | 224 | (`(,(or `defvar `defconst) . ,_) (macroexp--all-forms form 2)) |
| 217 | (`(function ,(and f `(lambda . ,_))) | 225 | (`(function ,(and f `(lambda . ,_))) |
| 218 | (macroexp--cons 'function | 226 | (macroexp--cons 'function |
| 219 | (macroexp--cons (macroexp--all-forms f 2) | 227 | (macroexp--cons (macroexp--all-forms f 2) |
| 220 | nil | 228 | nil |
| 221 | (cdr form)) | 229 | (cdr form)) |
| 222 | form)) | 230 | form)) |
| 223 | (`(,(or `function `quote) . ,_) form) | 231 | (`(,(or `function `quote) . ,_) form) |
| 224 | (`(,(and fun (or `let `let*)) . ,(or `(,bindings . ,body) dontcare)) | 232 | (`(,(and fun (or `let `let*)) . ,(or `(,bindings . ,body) dontcare)) |
| 225 | (macroexp--cons fun | 233 | (macroexp--cons fun |
| 226 | (macroexp--cons (macroexp--all-clauses bindings 1) | 234 | (macroexp--cons (macroexp--all-clauses bindings 1) |
| 227 | (macroexp--all-forms body) | 235 | (macroexp--all-forms body) |
| 228 | (cdr form)) | 236 | (cdr form)) |
| 229 | form)) | 237 | form)) |
| 230 | (`(,(and fun `(lambda . ,_)) . ,args) | 238 | (`(,(and fun `(lambda . ,_)) . ,args) |
| 231 | ;; Embedded lambda in function position. | 239 | ;; Embedded lambda in function position. |
| 232 | (macroexp--cons (macroexp--all-forms fun 2) | 240 | (macroexp--cons (macroexp--all-forms fun 2) |
| 233 | (macroexp--all-forms args) | 241 | (macroexp--all-forms args) |
| 234 | form)) | 242 | form)) |
| 235 | ;; The following few cases are for normal function calls that | 243 | ;; The following few cases are for normal function calls that |
| 236 | ;; are known to funcall one of their arguments. The byte | 244 | ;; are known to funcall one of their arguments. The byte |
| 237 | ;; compiler has traditionally handled these functions specially | 245 | ;; compiler has traditionally handled these functions specially |
diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 0a22c5ebcff..1c7a68abdec 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el | |||
| @@ -33,6 +33,7 @@ | |||
| 33 | ;;; Code: | 33 | ;;; Code: |
| 34 | 34 | ||
| 35 | (require 'cl-lib) | 35 | (require 'cl-lib) |
| 36 | (require 'help-mode) | ||
| 36 | 37 | ||
| 37 | (defvar help-fns-describe-function-functions nil | 38 | (defvar help-fns-describe-function-functions nil |
| 38 | "List of functions to run in help buffer in `describe-function'. | 39 | "List of functions to run in help buffer in `describe-function'. |
| @@ -970,15 +971,6 @@ file-local variable.\n") | |||
| 970 | (buffer-string)))))))) | 971 | (buffer-string)))))))) |
| 971 | 972 | ||
| 972 | 973 | ||
| 973 | (defvar describe-symbol-backends | ||
| 974 | `((nil ,#'fboundp ,(lambda (s _b _f) (describe-function s))) | ||
| 975 | ("face" ,#'facep ,(lambda (s _b _f) (describe-face s))) | ||
| 976 | (nil | ||
| 977 | ,(lambda (symbol) | ||
| 978 | (or (and (boundp symbol) (not (keywordp symbol))) | ||
| 979 | (get symbol 'variable-documentation))) | ||
| 980 | ,#'describe-variable))) | ||
| 981 | |||
| 982 | (defvar help-xref-stack-item) | 974 | (defvar help-xref-stack-item) |
| 983 | 975 | ||
| 984 | ;;;###autoload | 976 | ;;;###autoload |
| @@ -986,23 +978,22 @@ file-local variable.\n") | |||
| 986 | "Display the full documentation of SYMBOL. | 978 | "Display the full documentation of SYMBOL. |
| 987 | Will show the info of SYMBOL as a function, variable, and/or face." | 979 | Will show the info of SYMBOL as a function, variable, and/or face." |
| 988 | (interactive | 980 | (interactive |
| 989 | ;; FIXME: also let the user enter a face name. | 981 | (let* ((v-or-f (symbol-at-point)) |
| 990 | (let* ((v-or-f (variable-at-point)) | 982 | (found (cl-some (lambda (x) (funcall (nth 1 x) v-or-f)) |
| 991 | (found (symbolp v-or-f)) | 983 | describe-symbol-backends)) |
| 992 | (v-or-f (if found v-or-f (function-called-at-point))) | 984 | (v-or-f (if found v-or-f (function-called-at-point))) |
| 993 | (found (or found v-or-f)) | 985 | (found (or found v-or-f)) |
| 994 | (enable-recursive-minibuffers t) | 986 | (enable-recursive-minibuffers t) |
| 995 | val) | 987 | (val (completing-read (if found |
| 996 | (setq val (completing-read (if found | ||
| 997 | (format | 988 | (format |
| 998 | "Describe symbol (default %s): " v-or-f) | 989 | "Describe symbol (default %s): " v-or-f) |
| 999 | "Describe symbol: ") | 990 | "Describe symbol: ") |
| 1000 | obarray | 991 | obarray |
| 1001 | (lambda (vv) | 992 | (lambda (vv) |
| 1002 | (cl-some (lambda (x) (funcall (nth 1 x) vv)) | 993 | (cl-some (lambda (x) (funcall (nth 1 x) vv)) |
| 1003 | describe-symbol-backends)) | 994 | describe-symbol-backends)) |
| 1004 | t nil nil | 995 | t nil nil |
| 1005 | (if found (symbol-name v-or-f)))) | 996 | (if found (symbol-name v-or-f))))) |
| 1006 | (list (if (equal val "") | 997 | (list (if (equal val "") |
| 1007 | v-or-f (intern val))))) | 998 | v-or-f (intern val))))) |
| 1008 | (if (not (symbolp symbol)) | 999 | (if (not (symbolp symbol)) |
diff --git a/lisp/help-mode.el b/lisp/help-mode.el index cdddd542532..e1fc9fd1984 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el | |||
| @@ -30,6 +30,7 @@ | |||
| 30 | ;;; Code: | 30 | ;;; Code: |
| 31 | 31 | ||
| 32 | (require 'button) | 32 | (require 'button) |
| 33 | (require 'cl-lib) | ||
| 33 | (eval-when-compile (require 'easymenu)) | 34 | (eval-when-compile (require 'easymenu)) |
| 34 | 35 | ||
| 35 | (defvar help-mode-map | 36 | (defvar help-mode-map |
| @@ -216,7 +217,8 @@ The format is (FUNCTION ARGS...).") | |||
| 216 | (goto-char (point-min)) | 217 | (goto-char (point-min)) |
| 217 | (if (re-search-forward | 218 | (if (re-search-forward |
| 218 | (format "^[ \t]*(\\(cl-\\)?define-compiler-macro[ \t]+%s" | 219 | (format "^[ \t]*(\\(cl-\\)?define-compiler-macro[ \t]+%s" |
| 219 | (regexp-quote (symbol-name fun))) nil t) | 220 | (regexp-quote (symbol-name fun))) |
| 221 | nil t) | ||
| 220 | (forward-line 0) | 222 | (forward-line 0) |
| 221 | (message "Unable to find location in file"))) | 223 | (message "Unable to find location in file"))) |
| 222 | (message "Unable to find file"))) | 224 | (message "Unable to find file"))) |
| @@ -385,6 +387,15 @@ it does not already exist." | |||
| 385 | (error "Current buffer is not in Help mode")) | 387 | (error "Current buffer is not in Help mode")) |
| 386 | (current-buffer)))) | 388 | (current-buffer)))) |
| 387 | 389 | ||
| 390 | (defvar describe-symbol-backends | ||
| 391 | `((nil ,#'fboundp ,(lambda (s _b _f) (describe-function s))) | ||
| 392 | ("face" ,#'facep ,(lambda (s _b _f) (describe-face s))) | ||
| 393 | (nil | ||
| 394 | ,(lambda (symbol) | ||
| 395 | (or (and (boundp symbol) (not (keywordp symbol))) | ||
| 396 | (get symbol 'variable-documentation))) | ||
| 397 | ,#'describe-variable))) | ||
| 398 | |||
| 388 | ;;;###autoload | 399 | ;;;###autoload |
| 389 | (defun help-make-xrefs (&optional buffer) | 400 | (defun help-make-xrefs (&optional buffer) |
| 390 | "Parse and hyperlink documentation cross-references in the given BUFFER. | 401 | "Parse and hyperlink documentation cross-references in the given BUFFER. |
| @@ -487,28 +498,9 @@ that." | |||
| 487 | ;; (pop-to-buffer (car location)) | 498 | ;; (pop-to-buffer (car location)) |
| 488 | ;; (goto-char (cdr location)))) | 499 | ;; (goto-char (cdr location)))) |
| 489 | (help-xref-button 8 'help-function-def sym)) | 500 | (help-xref-button 8 'help-function-def sym)) |
| 490 | ((and | 501 | ((cl-some (lambda (x) (funcall (nth 1 x) sym)) |
| 491 | (facep sym) | 502 | describe-symbol-backends) |
| 492 | (save-match-data (looking-at "[ \t\n]+face\\W"))) | 503 | (help-xref-button 8 'help-symbol sym))))))) |
| 493 | (help-xref-button 8 'help-face sym)) | ||
| 494 | ((and (or (boundp sym) | ||
| 495 | (get sym 'variable-documentation)) | ||
| 496 | (fboundp sym)) | ||
| 497 | ;; We can't intuit whether to use the | ||
| 498 | ;; variable or function doc -- supply both. | ||
| 499 | (help-xref-button 8 'help-symbol sym)) | ||
| 500 | ((and | ||
| 501 | (or (boundp sym) | ||
| 502 | (get sym 'variable-documentation)) | ||
| 503 | (or | ||
| 504 | (documentation-property | ||
| 505 | sym 'variable-documentation) | ||
| 506 | (documentation-property | ||
| 507 | (indirect-variable sym) | ||
| 508 | 'variable-documentation))) | ||
| 509 | (help-xref-button 8 'help-variable sym)) | ||
| 510 | ((fboundp sym) | ||
| 511 | (help-xref-button 8 'help-function sym))))))) | ||
| 512 | ;; An obvious case of a key substitution: | 504 | ;; An obvious case of a key substitution: |
| 513 | (save-excursion | 505 | (save-excursion |
| 514 | (while (re-search-forward | 506 | (while (re-search-forward |