diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 989f8f5ce20..caa02fb24b2 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/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 - ;; apparently harmless computation, so it should not - ;; touch the match-data. - (save-match-data - (help--docstring-quote - (let ((print-gensym nil) (print-quoted t) - (print-escape-newlines t)) - (format "%S" (cons 'fn (cl--make-usage-args - orig-args)))))))) + ;; Macro expansion can take place in the middle of + ;; apparently harmless computation, so it should not + ;; touch the match-data. + (save-match-data + (require 'help) + (help--docstring-quote + (let ((print-gensym nil) (print-quoted t) + (print-escape-newlines t)) + (format "%S" (cons 'fn (cl--make-usage-args + orig-args)))))))) (when (memq '&optional simple-args) (decf slen)) (setq header diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index d75a32a8d4e..f6376fbd192 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/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) - "Abstract type of functions compiled to machine code.") -(cl--define-built-in-type module-function (function) +(cl--define-built-in-type subr (atom) ;Beware: not always a function. + "Abstract type of functions and special forms compiled to machine code.") +(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.") diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 7bb7d4a6b27..6126679e870 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/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) - (keywordp symbolp) - (characterp fixnump) - (natnump integerp) - (facep symbolp stringp) - (plistp listp) - (cl-struct-p recordp) - ;; ;; FIXME: These aren't quite in the same - ;; ;; category since they'll signal errors. - (fboundp symbolp) - )) - (puthash (car pred-types) - (apply #'logior - (mapcar (lambda (pred) - (gethash pred bitsets)) - (cdr pred-types))) - bitsets)) + ;; Beware: For these predicates, the bitsets are conservative + ;; approximations (so, e.g., it wouldn't be correct to use one of + ;; them after a `!' since the negation would be an unsound + ;; under-approximation). + (let ((all (1- i))) + (dolist (pred-types '((functionp cl-functionp consp symbolp) + (keywordp symbolp) + (nlistp ! listp) + (characterp fixnump) + (natnump integerp) + (facep symbolp stringp) + (plistp listp) + (cl-struct-p recordp) + ;; ;; FIXME: These aren't quite in the same + ;; ;; category since they'll signal errors. + (fboundp symbolp) + )) + (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