mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-01-30 04:10:54 -08:00
Code Issues Projects Releases Wiki Activity

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

Browse source 
`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.
This commit is contained in:
Stefan Monnier 2026-01-27 11:17:37 -05:00
parent 4fae092e2d
commit 6e2a4b8111
3 changed files with 64 additions and 35 deletions
Download patch file Download diff file Expand all files Collapse all files

19
lisp/emacs-lisp/cl-macs.el
View file

@ -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

24
lisp/emacs-lisp/cl-preloaded.el
View file

@ -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.")

56
lisp/emacs-lisp/pcase.el
View file

@ -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