mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-15 10:30:25 -08:00
Code Issues Projects Releases Wiki Activity

(cl-deftype): Precompute the predicate function

Browse source 
Always define a `cl-deftype-satisfies` predicate (if possible), so
we only need `cl-typep` to "interpret" a type specifier when we use
a compound type but never for the atomic types (e.g. never
in `cl-types-of`).

* lisp/emacs-lisp/cl-macs.el (cl-typep): Test `cl-deftype-satisfies` first.
Don't handle `real` here any more.
(base-char, character, command, keyword, natnum, real): Define with
`c-deftype`.
(cl-deftype): Precompute the predicate for the atomic derived type,
if applicable.

* lisp/emacs-lisp/cl-preloaded.el (cl--define-derived-type):
Add argument for the precomputed predicate function.

* lisp/emacs-lisp/cl-extra.el (cl-types-of): Use `cl-deftype-satisfies`
instead of `cl-type-p`.
This commit is contained in:
Stefan Monnier 2025-05-07 23:17:41 -04:00
parent a918f9e640
commit 777da8c3f9
3 changed files with 77 additions and 45 deletions
Download patch file Download diff file Expand all files Collapse all files

30
lisp/emacs-lisp/cl-extra.el
View file

@ -1034,20 +1034,22 @@ TYPES is an internal argument."
(let* ((found nil))
;; Build a list of all types OBJECT belongs to.
(dolist (type (or types cl--derived-type-list))
(and
;; If OBJECT is of type, add type to the matching list.
(if types
;; For method dispatch, we don't need to filter out errors,
;; since we can presume that method dispatch is used only on
;; sanely-defined types.
(cl-typep object type)
(condition-case-unless-debug e
(cl-typep object type)
(error (setq cl--derived-type-list (delq type cl--derived-type-list))
(warn "cl-types-of %S: %s"
type (error-message-string e))
nil)))
(push type found)))
(let ((pred (get type 'cl-deftype-satisfies)))
(and
;; If OBJECT is of type, add type to the matching list.
(if types
;; For method dispatch, we don't need to filter out errors,
;; since we can presume that method dispatch is used only on
;; sanely-defined types.
(funcall pred object)
(condition-case-unless-debug e
(funcall pred object)
(error (setq cl--derived-type-list
(delq type cl--derived-type-list))
(warn "cl-types-of %S: %s"
type (error-message-string e))
nil)))
(push type found))))
(push (cl-type-of object) found)
;; Return the list of types OBJECT belongs to, which is also the list
;; of specifiers for OBJECT. This memoization has two purposes: