(pcase--subtype-bitsets): Make it a bit more precise

`null`, `booleanp`, and `symbolp` were treated as equivalent in
`pcase--subtype-bitsets`, which was not incorrect to the extent
that we currently use this table only to detect
mutual-exclusion, but made it incorrect to use that same table
to test things like inclusion.

* lisp/emacs-lisp/cl-preloaded.el (built-in-class): New slot
`non-abstract-supertype`.
(cl--define-built-in-type): Add corresponding keyword argument.
(symbol, boolean): Use it.

* lisp/emacs-lisp/pcase.el (pcase--subtype-bitsets): Use it.

* lisp/emacs-lisp/cl-macs.el (cl--transform-lambda): Require `help`
before calling `help--docstring-quote`.  Fixes a corner case bootstrap
problem found along the way.

lisp/emacs-lisp/cl-macs.el

@@ -327,15 +327,16 @@ FORM is of the form (ARGS . BODY)."
               ;; "manual" parsing.
               (let ((slen (length simple-args))
                     (usage-str
-                      ;; Macro expansion can take place in the middle of
+                     ;; Macro expansion can take place in the middle of
-                      ;; apparently harmless computation, so it should not
+                     ;; apparently harmless computation, so it should not
-                      ;; touch the match-data.
+                     ;; touch the match-data.
-                      (save-match-data
+                     (save-match-data
-                        (help--docstring-quote
+                       (require 'help)
-                         (let ((print-gensym nil) (print-quoted t)
+                       (help--docstring-quote
-                               (print-escape-newlines t))
+                        (let ((print-gensym nil) (print-quoted t)
-                           (format "%S" (cons 'fn (cl--make-usage-args
+                              (print-escape-newlines t))
-                                                   orig-args))))))))
+                          (format "%S" (cons 'fn (cl--make-usage-args
+                                                  orig-args))))))))
                 (when (memq '&optional simple-args)
                   (decf slen))
                 (setq header

lisp/emacs-lisp/cl-preloaded.el

@@ -296,10 +296,11 @@
 
 (cl-defstruct (built-in-class
                (:include cl--class)
+               (:conc-name built-in-class--)
                (:noinline t)
                (:constructor nil)
                (:constructor built-in-class--make
-                (name docstring parent-types
+                (name docstring parent-types &optional non-abstract-supertype
                       &aux (parents
                             (mapcar (lambda (type)
                                       (or (get type 'cl--class)
@@ -308,7 +309,9 @@
                (:copier nil))
   "Type descriptors for built-in types.
 The `slots' (and hence `index-table') are currently unused."
-  )
+  ;; As a general rule, built-in types are abstract if-and-only-if they have
+  ;; other built-in types as subtypes.  But there are a few exceptions.
+  (non-abstract-supertype nil :read-only t))
 
 (defmacro cl--define-built-in-type (name parents &optional docstring &rest slots)
   ;; `slots' is currently unused, but we could make it take
@@ -322,19 +325,22 @@ The `slots' (and hence `index-table') are currently unused."
   (let ((predicate (intern-soft (format
                                  (if (string-match "-" (symbol-name name))
                                      "%s-p" "%sp")
-                                 name))))
+                                 name)))
+        (nas nil))
     (unless (fboundp predicate) (setq predicate nil))
     (while (keywordp (car slots))
       (let ((kw (pop slots)) (val (pop slots)))
         (pcase kw
           (:predicate (setq predicate val))
+          (:non-abstract-supertype (setq nas val))
           (_ (error "Unknown keyword arg: %S" kw)))))
     `(progn
        ,(if predicate `(put ',name 'cl-deftype-satisfies #',predicate)
           ;; (message "Missing predicate for: %S" name)
           nil)
        (put ',name 'cl--class
-            (built-in-class--make ',name ,docstring ',parents)))))
+            (built-in-class--make ',name ,docstring ',parents
+                                  ,@(if nas '(t)))))))
 
 ;; FIXME: Our type DAG has various quirks:
 ;; - Some `keyword's are also `symbol-with-pos' but that's not reflected
@@ -381,6 +387,7 @@ regardless if `funcall' would accept to call them."
   "Abstract supertype of both `number's and `marker's.")
 (cl--define-built-in-type symbol atom
   "Type of symbols."
+  :non-abstract-supertype t
   ;; 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
@@ -411,7 +418,8 @@ 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 boolean (symbol)
-  "Type of the canonical boolean values, i.e. either nil or t.")
+  "Type of the canonical boolean values, i.e. either nil or t."
+  :non-abstract-supertype 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))
@@ -450,9 +458,9 @@ The fields are used as follows:
   5 [iform]      The interactive form (if present)")
 (cl--define-built-in-type byte-code-function (compiled-function closure)
   "Type of functions that have been byte-compiled.")
-(cl--define-built-in-type subr (atom)
+(cl--define-built-in-type subr (atom)   ;Beware: not always a function.
-  "Abstract type of functions compiled to machine code.")
+  "Abstract type of functions and special forms compiled to machine code.")
-(cl--define-built-in-type module-function (function)
+(cl--define-built-in-type module-function (compiled-function)
   "Type of functions provided via the module API.")
 (cl--define-built-in-type interpreted-function (closure)
   "Type of functions that have not been compiled.")

lisp/emacs-lisp/pcase.el

@@ -662,13 +662,22 @@ recording whether the var has been referenced by earlier parts of the match."
                                (lambda (x y)
                                  (> (length (nth 2 x)) (length (nth 2 y))))))
 
+    ;; We presume that the "fundamental types" (i.e. the built-in types
+    ;; that have no subtypes) are all mutually exclusive and give them
+    ;; one bit each in bitsets.
+    ;; The "non-abstract-supertypes" also get their own bit.
+    ;; All other built-in types are abstract, so they don't need their
+    ;; own bits (they are faithfully modeled by the set of bits
+    ;; corresponding to their subtypes).
     (let ((bitsets (make-hash-table))
           (i 1))
       (dolist (x built-in-types)
         ;; Don't dedicate any bit to those predicates which already
         ;; have a bitset, since it means they're already represented
         ;; by their subtypes.
-        (unless (and (nth 1 x) (gethash (nth 1 x) bitsets))
+        (unless (and (nth 1 x) (gethash (nth 1 x) bitsets)
+                     (not (built-in-class--non-abstract-supertype
+                           (get (nth 0 x) 'cl--class))))
           (dolist (parent (nth 2 x))
             (let ((pred (nth 1 (assq parent built-in-types))))
               (unless (or (eq parent t) (null pred))
@@ -676,24 +685,35 @@ recording whether the var has been referenced by earlier parts of the match."
                          bitsets))))
           (setq i (+ i i))))
 
+      ;; (cl-assert (= (1- i) (apply #'logior (map-values bitsets))))
+
       ;; Extra predicates that don't have matching types.
-      (dolist (pred-types '((functionp cl-functionp consp symbolp)
+      ;; Beware: For these predicates, the bitsets are conservative
-                            (keywordp symbolp)
+      ;; approximations (so, e.g., it wouldn't be correct to use one of
-                            (characterp fixnump)
+      ;; them after a `!' since the negation would be an unsound
-                            (natnump integerp)
+      ;; under-approximation).
-                            (facep symbolp stringp)
+      (let ((all (1- i)))
-                            (plistp listp)
+        (dolist (pred-types '((functionp cl-functionp consp symbolp)
-                            (cl-struct-p recordp)
+                              (keywordp symbolp)
-                            ;; ;; FIXME: These aren't quite in the same
+                              (nlistp ! listp)
-                            ;; ;; category since they'll signal errors.
+                              (characterp fixnump)
-                            (fboundp symbolp)
+                              (natnump integerp)
-                            ))
+                              (facep symbolp stringp)
-        (puthash (car pred-types)
+                              (plistp listp)
-                 (apply #'logior
+                              (cl-struct-p recordp)
-                        (mapcar (lambda (pred)
+                              ;; ;; FIXME: These aren't quite in the same
-                                  (gethash pred bitsets))
+                              ;; ;; category since they'll signal errors.
-                                (cdr pred-types)))
+                              (fboundp symbolp)
-                 bitsets))
+                              ))
+          (let* ((types (cdr pred-types))
+                 (neg (when (eq '! (car types)) (setq types (cdr types))))
+                 (bitset (apply #'logior
+                                (mapcar (lambda (pred)
+                                          (gethash pred bitsets))
+                                        types))))
+            (puthash (car pred-types)
+                     (if neg (- all bitset) bitset)
+                     bitsets))))
       bitsets)))
 
 (defconst pcase--subtype-bitsets