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.

(cherry picked from commit 4fdcbd09af29e72456c9ca4cfbc9f6e97a88f8b8)

diff --git a/etc/NEWS b/etc/NEWS
index 2dbec86be777d40de2d9984d49618254ffec2d99..e81fff8cd8fc67d722a1e6fccb7f6620048ad7a6 100644 (file)
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -1750,6 +1750,11 @@ the region and never want to restrict 'undo' to that region, it is
 preferable to use the existing 'undo-inhibit-region' symbol property
 instead of this variable.
 
+** 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.

diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 9281cd9821e085d4449c6b97e758a9777b910209..c8eaca9a77c981535e2193bfbfa5344a2a728198 100644 (file)
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -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))

diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index ea08d35ecec14fc661e8a8a1a96f6994b7508add..882b4b5939b81476a215f814ab5e9708741bc83a 100644 (file)
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -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)))))