aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2015-07-07 02:14:16 -0400
committerStefan Monnier2015-07-07 02:14:16 -0400
commit59b5723c9b613f14cd60cd3239cfdbc0d2343b18 (patch)
tree923edc0b04619ab41af69078d8cd9e3f86df5038
parent287bce988895b104c33d53faacfffd91d8d8e0f1 (diff)
downloademacs-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.el163
-rw-r--r--lisp/emacs-lisp/cl-generic.el71
-rw-r--r--lisp/emacs-lisp/cl-macs.el22
-rw-r--r--lisp/emacs-lisp/cl-preloaded.el1
-rw-r--r--lisp/emacs-lisp/eieio-core.el96
-rw-r--r--lisp/emacs-lisp/eieio-opt.el156
-rw-r--r--lisp/emacs-lisp/eieio.el19
-rw-r--r--lisp/emacs-lisp/lisp-mode.el7
-rw-r--r--lisp/emacs-lisp/macroexp.el52
-rw-r--r--lisp/help-fns.el23
-rw-r--r--lisp/help-mode.el38
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.
840Outputs 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.
907Optional TYPE argument returns only those functions that contain
908methods 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.
925The 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.
2864The returned zero-based slot index is relative to the start of 2862The 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.
266SLOTS are the slots residing in that class definition, and OPTIONS 268SLOTS 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.
83If 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.
164Outputs 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.
278Optional CLASS argument returns only those functions that contain
279methods 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.
296The 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")
992Print help description for CLASS.
993If 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" "\
998Describe CTR if it is a class constructor. 999Describe 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.
987Will show the info of SYMBOL as a function, variable, and/or face." 979Will 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