1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-06 06:20:55 -08:00

cl-preloaded.el (built-in-class): New type

Add classes describing the built-in types.

* lisp/emacs-lisp/cl-preloaded.el (built-in-class): New type.
(cl--define-built-in-type): New aux macro.
(all built-in types): "Define" them with it.
(cl--builtin-type-p): New aux function.
(cl--struct-name-p): Use it.
(cl--direct-supertypes-of-type, cl--typeof-types, cl--all-builtin-types):
Move the definitions to after the built-in classes are defined,
and rewrite to make use of those classes.

* lisp/emacs-lisp/cl-extra.el (cl-describe-type):
Accept two (unused) optional args, for use with `describe-symbol-backends`.
(describe-symbol-backends): Simplify accordingly and
add ourselves at the end.
(cl--class-children): New function.
(cl--describe-class): Use it.  Also don't show a silly empty list of slots
for the built-in types.
This commit is contained in:
Stefan Monnier 2024-03-06 16:32:35 -05:00
parent 9830421e96
commit 4fdcbd09af
3 changed files with 200 additions and 102 deletions

View file

@ -714,7 +714,9 @@ PROPLIST is a list of the sort returned by `symbol-plist'.
;; FIXME: We could go crazy and add another entry so describe-symbol can be
;; used with the slot names of CL structs (and/or EIEIO objects).
(add-to-list 'describe-symbol-backends
`(nil ,#'cl-find-class ,(lambda (s _b _f) (cl-describe-type s))))
`(nil ,#'cl-find-class ,#'cl-describe-type)
;; Document the `cons` function before the `cons` type.
t)
(defconst cl--typedef-regexp
(concat "(" (regexp-opt '("defclass" "defstruct" "cl-defstruct"
@ -744,7 +746,7 @@ Call `cl--find-class' to get TYPE's propname `cl--class'"
(cl--find-class type))
;;;###autoload
(defun cl-describe-type (type)
(defun cl-describe-type (type &optional _buf _frame)
"Display the documentation for type TYPE (a symbol)."
(interactive
(let ((str (completing-read "Describe type: " obarray #'cl-find-class t)))
@ -766,6 +768,15 @@ Call `cl--find-class' to get TYPE's propname `cl--class'"
;; Return the text we displayed.
(buffer-string)))))
(defun cl--class-children (class)
(let ((children '()))
(mapatoms
(lambda (sym)
(let ((sym-class (cl--find-class sym)))
(and sym-class (memq class (cl--class-parents sym-class))
(push sym children)))))
children))
(defun cl--describe-class (type &optional class)
(unless class (setq class (cl--find-class type)))
(let ((location (find-lisp-object-file-name type 'define-type))
@ -796,10 +807,8 @@ Call `cl--find-class' to get TYPE's propname `cl--class'"
(insert (substitute-command-keys (if pl "', " "'"))))
(insert ".\n")))
;; Children, if available. ¡For EIEIO!
(let ((ch (condition-case nil
(cl-struct-slot-value metatype 'children class)
(cl-struct-unknown-slot nil)))
;; Children.
(let ((ch (cl--class-children class))
cur)
(when ch
(insert " Children ")
@ -903,22 +912,25 @@ Outputs to the current buffer."
(cslots (condition-case nil
(cl-struct-slot-value metatype 'class-slots class)
(cl-struct-unknown-slot nil))))
(insert (propertize "Instance Allocated Slots:\n\n"
'face 'bold))
(let* ((has-doc nil)
(slots-strings
(mapcar
(lambda (slot)
(list (cl-prin1-to-string (cl--slot-descriptor-name slot))
(cl-prin1-to-string (cl--slot-descriptor-type slot))
(cl-prin1-to-string (cl--slot-descriptor-initform slot))
(let ((doc (alist-get :documentation
(cl--slot-descriptor-props slot))))
(if (not doc) ""
(setq has-doc t)
(substitute-command-keys doc)))))
slots)))
(cl--print-table `("Name" "Type" "Default") slots-strings has-doc))
(if (and (null slots) (eq metatype 'built-in-class))
(insert "This is a built-in type.\n")
(insert (propertize "Instance Allocated Slots:\n\n"
'face 'bold))
(let* ((has-doc nil)
(slots-strings
(mapcar
(lambda (slot)
(list (cl-prin1-to-string (cl--slot-descriptor-name slot))
(cl-prin1-to-string (cl--slot-descriptor-type slot))
(cl-prin1-to-string (cl--slot-descriptor-initform slot))
(let ((doc (alist-get :documentation
(cl--slot-descriptor-props slot))))
(if (not doc) ""
(setq has-doc t)
(substitute-command-keys doc)))))
slots)))
(cl--print-table `("Name" "Type" "Default") slots-strings has-doc)))
(insert "\n")
(when (> (length cslots) 0)
(insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold))