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
parent
9830421e96
commit
4fdcbd09af
3 changed files with 200 additions and 102 deletions
5
etc/NEWS
5
etc/NEWS
|
|
@ -1612,6 +1612,11 @@ values.
|
|||
|
||||
* Lisp Changes in Emacs 30.1
|
||||
|
||||
** Built-in types have now corresponding classes.
|
||||
At the Lisp level, this means that things like (cl-find-class 'integer)
|
||||
will now return a class object, and at the UI level it means that
|
||||
things like 'C-h o integer RET' will show some information about that type.
|
||||
|
||||
** New var 'major-mode-remap-defaults' and function 'major-mode-remap'.
|
||||
The first is like Emacs-29's 'major-mode-remap-alist' but to be set by
|
||||
packages (instead of users). The second looks up those two variables.
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -50,90 +50,16 @@
|
|||
(apply #'error string (append sargs args))
|
||||
(signal 'cl-assertion-failed `(,form ,@sargs)))))
|
||||
|
||||
(defconst cl--direct-supertypes-of-type
|
||||
;; Please run `sycdoc-update-type-hierarchy' in
|
||||
;; `admin/syncdoc-type-hierarchy.el' each time this is modified to
|
||||
;; reflect the change in the documentation.
|
||||
(let ((table (make-hash-table :test #'eq)))
|
||||
;; FIXME: Our type DAG has various quirks:
|
||||
;; - `subr' says it's a `compiled-function' but that's not true
|
||||
;; for those subrs that are special forms!
|
||||
;; - Some `keyword's are also `symbol-with-pos' but that's not reflected
|
||||
;; in the DAG.
|
||||
;; - An OClosure can be an interpreted function or a `byte-code-function',
|
||||
;; so the DAG of OClosure types is "orthogonal" to the distinction
|
||||
;; between interpreted and compiled functions.
|
||||
(dolist (x '((sequence t)
|
||||
(atom t)
|
||||
(list sequence)
|
||||
(array sequence atom)
|
||||
(float number)
|
||||
(integer number integer-or-marker)
|
||||
(marker integer-or-marker)
|
||||
(integer-or-marker number-or-marker)
|
||||
(number number-or-marker)
|
||||
(bignum integer)
|
||||
(fixnum integer)
|
||||
(keyword symbol)
|
||||
(boolean symbol)
|
||||
(symbol-with-pos symbol)
|
||||
(vector array)
|
||||
(bool-vector array)
|
||||
(char-table array)
|
||||
(string array)
|
||||
;; FIXME: This results in `atom' coming before `list' :-(
|
||||
(null boolean list)
|
||||
(cons list)
|
||||
(function atom)
|
||||
(byte-code-function compiled-function)
|
||||
(subr compiled-function)
|
||||
(module-function function)
|
||||
(compiled-function function)
|
||||
(subr-native-elisp subr)
|
||||
(subr-primitive subr)))
|
||||
(puthash (car x) (cdr x) table))
|
||||
;; And here's the flat part of the hierarchy.
|
||||
(dolist (atom '( tree-sitter-compiled-query tree-sitter-node
|
||||
tree-sitter-parser user-ptr
|
||||
font-object font-entity font-spec
|
||||
condvar mutex thread terminal hash-table frame
|
||||
;; function ;; FIXME: can be a list as well.
|
||||
buffer window process window-configuration
|
||||
overlay number-or-marker
|
||||
symbol obarray native-comp-unit))
|
||||
(cl-assert (null (gethash atom table)))
|
||||
(puthash atom '(atom) table))
|
||||
table)
|
||||
"Hash table TYPE -> SUPERTYPES.")
|
||||
|
||||
(defconst cl--typeof-types
|
||||
(letrec ((alist nil)
|
||||
(allparents
|
||||
(lambda (type)
|
||||
;; FIXME: copy&pasted from `cl--class-allparents'.
|
||||
(let ((parents (gethash type cl--direct-supertypes-of-type)))
|
||||
(unless parents
|
||||
(message "Warning: Type without parent: %S!" type))
|
||||
(cons type
|
||||
(merge-ordered-lists
|
||||
;; FIXME: Can't remember why `t' is excluded.
|
||||
(mapcar allparents (remq t parents))))))))
|
||||
(maphash (lambda (type _)
|
||||
(push (funcall allparents type) alist))
|
||||
cl--direct-supertypes-of-type)
|
||||
alist)
|
||||
"Alist of supertypes.
|
||||
Each element has the form (TYPE . SUPERTYPES) where TYPE is one of
|
||||
the symbols returned by `type-of', and SUPERTYPES is the list of its
|
||||
supertypes from the most specific to least specific.")
|
||||
|
||||
(defconst cl--all-builtin-types
|
||||
(delete-dups (copy-sequence (apply #'append cl--typeof-types))))
|
||||
(defun cl--builtin-type-p (name)
|
||||
(if (not (fboundp 'built-in-class-p)) ;; Early bootstrap
|
||||
nil
|
||||
(let ((class (and (symbolp name) (get name 'cl--class))))
|
||||
(and class (built-in-class-p class)))))
|
||||
|
||||
(defun cl--struct-name-p (name)
|
||||
"Return t if NAME is a valid structure name for `cl-defstruct'."
|
||||
(and name (symbolp name) (not (keywordp name))
|
||||
(not (memq name cl--all-builtin-types))))
|
||||
(not (cl--builtin-type-p name))))
|
||||
|
||||
;; When we load this (compiled) file during pre-loading, the cl--struct-class
|
||||
;; code below will need to access the `cl-struct' info, since it's considered
|
||||
|
|
@ -366,6 +292,161 @@ supertypes from the most specific to least specific.")
|
|||
(merge-ordered-lists (mapcar #'cl--class-allparents
|
||||
(cl--class-parents class)))))
|
||||
|
||||
(cl-defstruct (built-in-class
|
||||
(:include cl--class)
|
||||
(:constructor nil)
|
||||
(:constructor built-in-class--make (name docstring parents))
|
||||
(:copier nil))
|
||||
)
|
||||
|
||||
(defmacro cl--define-built-in-type (name parents &optional docstring &rest _slots)
|
||||
;; `slots' is currently unused, but we could make it take
|
||||
;; a list of "slot like properties" together with the corresponding
|
||||
;; accessor, and then we could maybe even make `slot-value' work
|
||||
;; on some built-in types :-)
|
||||
(declare (indent 2) (doc-string 3))
|
||||
(unless (listp parents) (setq parents (list parents)))
|
||||
(unless (or parents (eq name t))
|
||||
(error "Missing parents for %S: %S" name parents))
|
||||
`(progn
|
||||
(put ',name 'cl--class
|
||||
(built-in-class--make ',name ,docstring
|
||||
(mapcar (lambda (type)
|
||||
(let ((class (get type 'cl--class)))
|
||||
(unless class
|
||||
(error "Unknown type: %S" type))
|
||||
class))
|
||||
',parents)))))
|
||||
|
||||
;; FIXME: Our type DAG has various quirks:
|
||||
;; - `subr' says it's a `compiled-function' but that's not true
|
||||
;; for those subrs that are special forms!
|
||||
;; - Some `keyword's are also `symbol-with-pos' but that's not reflected
|
||||
;; in the DAG.
|
||||
;; - An OClosure can be an interpreted function or a `byte-code-function',
|
||||
;; so the DAG of OClosure types is "orthogonal" to the distinction
|
||||
;; between interpreted and compiled functions.
|
||||
|
||||
(cl--define-built-in-type t nil "The type of everything.")
|
||||
(cl--define-built-in-type atom t "The type of anything but cons cells.")
|
||||
|
||||
(cl--define-built-in-type tree-sitter-compiled-query atom)
|
||||
(cl--define-built-in-type tree-sitter-node atom)
|
||||
(cl--define-built-in-type tree-sitter-parser atom)
|
||||
(cl--define-built-in-type user-ptr atom)
|
||||
(cl--define-built-in-type font-object atom)
|
||||
(cl--define-built-in-type font-entity atom)
|
||||
(cl--define-built-in-type font-spec atom)
|
||||
(cl--define-built-in-type condvar atom)
|
||||
(cl--define-built-in-type mutex atom)
|
||||
(cl--define-built-in-type thread atom)
|
||||
(cl--define-built-in-type terminal atom)
|
||||
(cl--define-built-in-type hash-table atom)
|
||||
(cl--define-built-in-type frame atom)
|
||||
(cl--define-built-in-type buffer atom)
|
||||
(cl--define-built-in-type window atom)
|
||||
(cl--define-built-in-type process atom)
|
||||
(cl--define-built-in-type window-configuration atom)
|
||||
(cl--define-built-in-type overlay atom)
|
||||
(cl--define-built-in-type number-or-marker atom
|
||||
"Abstract super type of both `number's and `marker's.")
|
||||
(cl--define-built-in-type symbol atom
|
||||
"Type of symbols."
|
||||
;; Example of slots we could document. It would be desirable to
|
||||
;; have some way to extract this from the C code, or somehow keep it
|
||||
;; in sync (probably not for `cons' and `symbol' but for things like
|
||||
;; `font-entity').
|
||||
(name symbol-name)
|
||||
(value symbol-value)
|
||||
(function symbol-function)
|
||||
(plist symbol-plist))
|
||||
|
||||
(cl--define-built-in-type obarray atom)
|
||||
(cl--define-built-in-type native-comp-unit atom)
|
||||
|
||||
(cl--define-built-in-type sequence t "Abstract super type of sequences.")
|
||||
(cl--define-built-in-type list sequence)
|
||||
(cl--define-built-in-type array (sequence atom) "Abstract super type of arrays.")
|
||||
(cl--define-built-in-type number (number-or-marker)
|
||||
"Abstract super type of numbers.")
|
||||
(cl--define-built-in-type float (number))
|
||||
(cl--define-built-in-type integer-or-marker (number-or-marker)
|
||||
"Abstract super type of both `integer's and `marker's.")
|
||||
(cl--define-built-in-type integer (number integer-or-marker))
|
||||
(cl--define-built-in-type marker (integer-or-marker))
|
||||
(cl--define-built-in-type bignum (integer)
|
||||
"Type of those integers too large to fit in a `fixnum'.")
|
||||
(cl--define-built-in-type fixnum (integer)
|
||||
(format "Type of small (fixed-size) integers.
|
||||
The size depends on the Emacs version and compilation options.
|
||||
For this build of Emacs it's %dbit."
|
||||
(1+ (logb (1+ most-positive-fixnum)))))
|
||||
(cl--define-built-in-type keyword (symbol)
|
||||
"Type of those symbols whose first char is `:'.")
|
||||
(cl--define-built-in-type boolean (symbol)
|
||||
"Type of the canonical boolean values, i.e. either nil or t.")
|
||||
(cl--define-built-in-type symbol-with-pos (symbol)
|
||||
"Type of symbols augmented with source-position information.")
|
||||
(cl--define-built-in-type vector (array))
|
||||
(cl--define-built-in-type record (atom)
|
||||
"Abstract type of objects with slots.")
|
||||
(cl--define-built-in-type bool-vector (array) "Type of bitvectors.")
|
||||
(cl--define-built-in-type char-table (array)
|
||||
"Type of special arrays that are indexed by characters.")
|
||||
(cl--define-built-in-type string (array))
|
||||
(cl--define-built-in-type null (boolean list) ;FIXME: `atom' comes before `list'?
|
||||
"Type of the nil value.")
|
||||
(cl--define-built-in-type cons (list)
|
||||
"Type of cons cells."
|
||||
;; Example of slots we could document.
|
||||
(car car) (cdr cdr))
|
||||
(cl--define-built-in-type function (atom)
|
||||
"Abstract super type of function values.")
|
||||
(cl--define-built-in-type compiled-function (function)
|
||||
"Abstract type of functions that have been compiled.")
|
||||
(cl--define-built-in-type byte-code-function (compiled-function)
|
||||
"Type of functions that have been byte-compiled.")
|
||||
(cl--define-built-in-type subr (compiled-function)
|
||||
"Abstract type of functions compiled to machine code.")
|
||||
(cl--define-built-in-type module-function (function)
|
||||
"Type of functions provided via the module API.")
|
||||
(cl--define-built-in-type interpreted-function (function)
|
||||
"Type of functions that have not been compiled.")
|
||||
(cl--define-built-in-type subr-native-elisp (subr)
|
||||
"Type of function that have been compiled by the native compiler.")
|
||||
(cl--define-built-in-type subr-primitive (subr)
|
||||
"Type of functions hand written in C.")
|
||||
|
||||
(defconst cl--direct-supertypes-of-type
|
||||
;; Please run `sycdoc-update-type-hierarchy' in
|
||||
;; `admin/syncdoc-type-hierarchy.el' each time this is modified to
|
||||
;; reflect the change in the documentation.
|
||||
(let ((table (make-hash-table :test #'eq)))
|
||||
(mapatoms
|
||||
(lambda (type)
|
||||
(let ((class (get type 'cl--class)))
|
||||
(when (built-in-class-p class)
|
||||
(puthash type (mapcar #'cl--class-name (cl--class-parents class))
|
||||
table)))))
|
||||
table)
|
||||
"Hash table TYPE -> SUPERTYPES.")
|
||||
|
||||
(defconst cl--typeof-types
|
||||
(letrec ((alist nil))
|
||||
(maphash (lambda (type _)
|
||||
(let ((class (get type 'cl--class)))
|
||||
;; FIXME: Can't remember why `t' is excluded.
|
||||
(push (remq t (cl--class-allparents class)) alist)))
|
||||
cl--direct-supertypes-of-type)
|
||||
alist)
|
||||
"Alist of supertypes.
|
||||
Each element has the form (TYPE . SUPERTYPES) where TYPE is one of
|
||||
the symbols returned by `type-of', and SUPERTYPES is the list of its
|
||||
supertypes from the most specific to least specific.")
|
||||
|
||||
(defconst cl--all-builtin-types
|
||||
(delete-dups (copy-sequence (apply #'append cl--typeof-types))))
|
||||
|
||||
(eval-and-compile
|
||||
(cl-assert (null (cl--class-parents (cl--find-class 'cl-structure-object)))))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue