Re: master 1d9d07fb00e 3/3: (cl--typeof-types): Rework to fix some regressions

[Stefan Monnier]

> Yes I believe this affects the compiler as well.  I'd like to fix it, I
> just have to find some time to read some cl- code to understand how to
> distinguish them, the patch should be easy.

For context, here's a WiP patch that doesn't do the above, but is
somewhat related.

For what you describe, I think the better change is to change the
`parents` slot of cl-struct classes so it points either to 
`cl-structure-object` or
`array` or `list`.

IOW, instead of having hacks to add the right parent when `parents` is
nil, `parents` should "never" be nil (except for the `t` type).


        Stefan

commit fc271dd765f7201b5f87348f34f24b9a51982b4d
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Date:   Wed Mar 6 16:32:35 2024 -0500

    define-built-in-type

diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index cf09006a7ff..38ab20c16a2 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -716,7 +716,8 @@ cl-prettyexpand
 ;; 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 s)
+             t)
 
 (defconst cl--typedef-regexp
   (concat "(" (regexp-opt '("defclass" "defstruct" "cl-defstruct"
@@ -746,7 +747,7 @@ cl-find-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)))
@@ -768,6 +769,15 @@ cl-describe-type
         ;; 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))
@@ -798,10 +808,8 @@ cl--describe-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 ")
@@ -905,22 +913,25 @@ cl--describe-class-slots
          (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 a built-in type, with no exposed slots.\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-generic.el b/lisp/emacs-lisp/cl-generic.el
index 0b15f7737f2..b761b00aaa4 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -1510,27 +1510,6 @@ cl-generic-generalizers
 
 ;;; Dispatch on "system types".
 
-(defconst cl--generic-typeof-types
-  ;; Hand made from the source code of `type-of'.
-  (append cl--typeof-types
-          ;; Plus, really hand made:
-          '((null boolean symbol list sequence atom)
-            (boolean symbol list sequence atom)
-            (keyword symbol atom)
-            (base-char character natnum fixnum integer number atom)
-            (character natnum fixnum integer number atom)
-            (fixnum integer number atom)
-            (cl--generic-function-subr subr function atom)
-            (cl--generic-function-symbol function symbol atom)
-            (cl--generic-function-cons function cons list sequence)))
-  "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--generic-all-builtin-types
-  (delete-dups (copy-sequence (apply #'append cl--generic-typeof-types))))
-
 (defun cl--generic-typeof (x)
   "Like `type-of' but returns a more refined type."
   ;; FIXME: Add support for other types accepted by `cl-typep' such
@@ -1559,9 +1538,12 @@ cl--generic-typeof
     (ty ty)))
 
 (cl-generic-define-generalizer cl--generic-typeof-generalizer
-  10 (lambda (name &rest _) `(cl--generic-typeof ,name))
+  10 (lambda (name &rest _) `(type-of ,name)) ;; `(cl--generic-typeof ,name)
   (lambda (tag &rest _)
-    (and (symbolp tag) (assq tag cl--generic-typeof-types))))
+    (and (symbolp tag)
+         (let ((class (get tag 'cl--class)))
+           ;; Exclude t because it has its own generalizer.
+           (when class (remq t (cl--class-allparents class)))))))
 
 (cl-defmethod cl-generic-generalizers :extra "typeof" (type)
   "Support for dispatch on builtin types.
@@ -1570,13 +1552,10 @@ cl-generic-generalizers
    ;; FIXME: We could define two cl--generic-typeof-generalizers, one using
    ;; `cl--generic-typeof' and one using just `type-of' which we could
    ;; use when `type' doesn't need the refinement of cl--generic-typeof.
-   (and (memq type cl--all-builtin-types)
-        (progn
-          ;; FIXME: While this wrinkle in the semantics can be occasionally
-          ;; problematic, this warning is more often annoying than helpful.
-          ;;(if (memq type '(vector array sequence))
-          ;;    (message "`%S' also matches CL structs and EIEIO classes"
-          ;;             type))
+   (let ((class (and (symbolp type)
+                     ;; Exclude t because it has its own generalizer.
+                     (not (eq type t)) (get type 'cl--class))))
+     (and class (built-in-class-p class)
           (list cl--generic-typeof-generalizer)))
    (cl-call-next-method)))
 
diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el
index a93ba327b09..93737de7a90 100644
--- a/lisp/emacs-lisp/cl-preloaded.el
+++ b/lisp/emacs-lisp/cl-preloaded.el
@@ -52,91 +52,16 @@ cl--assertion-failed
         (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)
-                 (interpreted-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
@@ -369,6 +294,157 @@ cl--class-allparents
         (merge-ordered-lists (mapcar #'cl--class-allparents
                                      (cl--class-parents class)))))
 
+(cl-defstruct (built-in-class
+               (:include cl--class)
+               (:constructor nil)
+               (:constructor built-in-type--class
+                (name docstring parents &optional slots index-table))
+               (:copier nil))
+  )
+
+(defmacro 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-type--class ',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.
+
+(define-built-in-type t nil "The type of everything.")
+(define-built-in-type atom t "The type of anything but cons cells.")
+
+(define-built-in-type tree-sitter-compiled-query atom)
+(define-built-in-type tree-sitter-node atom)
+(define-built-in-type tree-sitter-parser atom)
+(define-built-in-type user-ptr atom)
+(define-built-in-type font-object atom)
+(define-built-in-type font-entity atom)
+(define-built-in-type font-spec atom)
+(define-built-in-type condvar atom)
+(define-built-in-type mutex atom)
+(define-built-in-type thread atom)
+(define-built-in-type terminal atom)
+(define-built-in-type hash-table atom)
+(define-built-in-type frame atom)
+(define-built-in-type buffer atom)
+(define-built-in-type window atom)
+(define-built-in-type process atom)
+(define-built-in-type window-configuration atom)
+(define-built-in-type overlay atom)
+(define-built-in-type number-or-marker atom
+  "Abstract super type of both `number's and `marker's.")
+(define-built-in-type symbol atom
+  "Type of symbols."
+  (name     symbol-name)
+  (value    symbol-value)
+  (function symbol-function)
+  (plist    symbol-plist))
+
+(define-built-in-type obarray atom)
+(define-built-in-type native-comp-unit atom)
+
+(define-built-in-type sequence t "Abstract super type of sequences.")
+(define-built-in-type list sequence)
+(define-built-in-type array (sequence atom) "Abstract super type of arrays.")
+(define-built-in-type number (number-or-marker)
+  "Abstract super type of numbers.")
+(define-built-in-type float (number))
+(define-built-in-type integer-or-marker (number-or-marker)
+  "Abstract super type of both `integer's and `marker's.")
+(define-built-in-type integer (number integer-or-marker))
+(define-built-in-type marker (integer-or-marker))
+(define-built-in-type bignum (integer)
+  "Type of those integers too large to fit in a `fixnum'.")
+(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)))))
+(define-built-in-type keyword (symbol)
+  "Type of those symbols whose first char is `:'.")
+(define-built-in-type boolean (symbol)
+  "Type of the canonical boolean values, i.e. either nil or t.")
+(define-built-in-type symbol-with-pos (symbol)
+  "Type of symbols augmented with source-position information.")
+(define-built-in-type vector (array))
+(define-built-in-type record (atom)
+  "Abstract type of typed objects with slots.")
+(define-built-in-type bool-vector (array) "Type of bitvectors.")
+(define-built-in-type char-table (array)
+  "Type of special arrays that are indexed by characters.")
+(define-built-in-type string (array))
+(define-built-in-type null (boolean list) ;FIXME: `atom' comes before `list'?
+  "Type of the nil value.")
+(define-built-in-type cons (list)
+  "Type of cons cells."
+  (car car) (cdr cdr))
+(define-built-in-type function (atom)
+  "Abstract super type of function values.")
+(define-built-in-type compiled-function (function)
+  "Abstract type of functions that have been compiled.")
+(define-built-in-type byte-code-function (compiled-function)
+  "Type of functions that have been byte-compiled.")
+(define-built-in-type subr (compiled-function)
+  "Abstract type of functions compiled to machine code.")
+(define-built-in-type module-function (function)
+  "Type of functions provided via the module API.")
+(define-built-in-type interpreted-function (function)
+  "Type of functions that have not been compiled.")
+(define-built-in-type subr-native-elisp (subr)
+  "Type of function that have been compiled by the native compiler.")
+(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)))))
 
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el
index 55d92841cd5..90a3ffbcff8 100644
--- a/lisp/emacs-lisp/comp-cstr.el
+++ b/lisp/emacs-lisp/comp-cstr.el
@@ -38,12 +38,6 @@
 (require 'cl-lib)
 (require 'cl-extra) ;HACK: For `cl-find-class' when `cl-loaddefs' is missing.
 
-(defconst comp--typeof-builtin-types (mapcar (lambda (x)
-                                               (append x '(t)))
-                                             cl--typeof-types)
-  ;; TODO can we just add t in `cl--typeof-types'?
-  "Like `cl--typeof-types' but with t as common supertype.")
-
 (cl-defstruct (comp-cstr (:constructor comp--type-to-cstr
                                        (type &aux
                                             (null (eq type 'null))
@@ -106,8 +100,7 @@ comp--all-classes
     res))
 
 (defun comp--compute-typeof-types ()
-  (append comp--typeof-builtin-types
-          (mapcar #'comp--cl-class-hierarchy (comp--all-classes))))
+  (mapcar #'comp--cl-class-hierarchy (comp--all-classes)))
 
 (defun comp--compute--pred-type-h ()
   (cl-loop with h = (make-hash-table :test #'eq)