From 990dc985ec8ef4940484f4fd7c042c72d37a9d22 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 7 May 2025 23:17:41 -0400 Subject: [PATCH] (cl-deftype): Precompute the predicate function 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`. (cherry picked from commit 777da8c3f9ea73077c00957d48d8e6b317b9657d) --- lisp/emacs-lisp/cl-extra.el | 30 ++++++------ lisp/emacs-lisp/cl-macs.el | 86 +++++++++++++++++++++------------ lisp/emacs-lisp/cl-preloaded.el | 8 ++- 3 files changed, 78 insertions(+), 46 deletions(-) diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 6f396bdbf0c..5569ec3d752 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -1036,20 +1036,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: diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 7cdf373d54c..221af7dfa69 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3502,32 +3502,20 @@ Of course, we really can't know that for sure, so it's just a heuristic." (or (cdr (assq sym byte-compile-function-environment)) (cdr (assq sym macroexpand-all-environment)))))) -;; Please keep it in sync with `comp-known-predicates'. -(pcase-dolist (`(,type . ,pred) - ;; Mostly kept in alphabetical order. - ;; These aren't defined via `cl--define-built-in-type'. - '((base-char . characterp) ;Could be subtype of `fixnum'. - (character . natnump) ;Could be subtype of `fixnum'. - (command . commandp) ;Subtype of closure & subr. - (keyword . keywordp) ;Would need `keyword-with-pos`. - (natnum . natnump) ;Subtype of fixnum & bignum. - (real . numberp) ;Not clear where it would fit. - ;; This one is redundant, but we keep it to silence a - ;; warning during the early bootstrap when `cl-seq.el' gets - ;; loaded before `cl-preloaded.el' is defined. - (list . listp) - )) - (put type 'cl-deftype-satisfies pred)) - ;;;###autoload (define-inline cl-typep (val type) "Return t if VAL is of type TYPE, nil otherwise." (inline-letevals (val) (pcase (inline-const-val type) + ((and (or (and type (pred symbolp)) `(,type)) + (guard (get type 'cl-deftype-satisfies))) + (inline-quote (funcall #',(get type 'cl-deftype-satisfies) ,val))) ((and `(,name . ,args) (guard (get name 'cl-deftype-handler))) (inline-quote (cl-typep ,val ',(apply (get name 'cl-deftype-handler) args)))) - (`(,(and name (or 'integer 'float 'real 'number)) + ;; FIXME: Move this to a `cl-deftype'. The problem being that these + ;; types are hybrid "built-in and derived". + (`(,(and name (or 'integer 'float 'number)) . ,(or `(,min ,max) pcase--dontcare)) (inline-quote (and (cl-typep ,val ',name) @@ -3561,8 +3549,6 @@ Of course, we really can't know that for sure, so it's just a heuristic." ((and (pred symbolp) type (guard (get type 'cl-deftype-handler))) (inline-quote (cl-typep ,val ',(funcall (get type 'cl-deftype-handler))))) - ((and (pred symbolp) type (guard (get type 'cl-deftype-satisfies))) - (inline-quote (funcall #',(get type 'cl-deftype-satisfies) ,val))) ((and (or 'nil 't) type) (inline-quote ',type)) ((and (pred symbolp) type) (macroexp-warn-and-return @@ -3763,18 +3749,58 @@ If PARENTS is non-nil, ARGLIST must be nil." (cl-callf (lambda (x) (delq declares x)) decls))) (and parents arglist (error "Parents specified, but arglist not empty")) - `(eval-and-compile - (cl--define-derived-type - ',name - (cl-function (lambda (&cl-defs ('*) ,@arglist) ,@decls ,@forms)) - ',parents)))) + (let* ((expander + `(cl-function (lambda (&cl-defs ('*) ,@arglist) ,@decls ,@forms))) + ;; FIXME: Pass a better lexical context. + (specifier (ignore-errors (funcall (eval expander t)))) + (predicate + (pcase specifier + (`(satisfies ,f) `#',f) + ('nil nil) + (type `(lambda (x) (cl-typep x ',type)))))) + `(eval-and-compile + (cl--define-derived-type + ',name ,expander ,predicate ',parents))))) (static-if (not (fboundp 'cl--define-derived-type)) - nil ;; Can't define it yet! - (cl-deftype extended-char () '(and character (not base-char)))) - -;;; Additional functions that we can now define because we've defined -;;; `cl-defsubst' and `cl-typep'. + nil ;; Can't define them yet! + (cl-deftype natnum () (declare (parents integer)) '(satisfies natnump)) + (cl-deftype character () (declare (parents fixnum natnum)) + '(and fixnum natnum)) + (cl-deftype base-char () (declare (parents character)) + '(satisfies characterp)) + (cl-deftype extended-char () (declare (parents character)) + '(and character (not base-char))) + (cl-deftype keyword () (declare (parents symbol)) '(satisfies keywordp)) + (cl-deftype command () + ;; FIXME: Can't use `function' as parent because of arrays as + ;; keyboard macros, which are redundant since `kmacro.el'!! + ;;(declare (parents function)) + '(satisfies commandp)) + ;; This one is redundant, but we keep it to silence a + ;; warning during the early bootstrap when `cl-seq.el' gets + ;; loaded before `cl-preloaded.el' is defined. + (put 'list 'cl-deftype-satisfies #'listp) + + (eval-when-compile + (defmacro cl--defnumtype (type base) + `(cl-deftype ,type (&optional min max) + (list 'and ',base + (if (memq min '(* nil)) t + (if (consp min) + `(satisfies . ,(lambda (val) (> val (car min)))) + `(satisfies . ,(lambda (val) (>= val min))))) + (if (memq max '(* nil)) t + (if (consp max) + `(satisfies . ,(lambda (val) (< val (car max)))) + `(satisfies . ,(lambda (val) (<= val max))))))))) + ;;(cl--defnumtype integer ??) + ;;(cl--defnumtype float ??) + ;;(cl--defnumtype number ??) + (cl--defnumtype real number)) + +;; Additional functions that we can now define because we've defined +;; `cl-defsubst' and `cl-typep'. (define-inline cl-struct-slot-value (struct-type slot-name inst) "Return the value of slot SLOT-NAME in INST of STRUCT-TYPE. diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 8956245f24c..e4b467ceb24 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -491,10 +491,12 @@ The fields are used as follows: (:copier nil)) "Type descriptors for derived types, i.e. defined by `cl-deftype'.") -(defun cl--define-derived-type (name expander &optional parents) +(defun cl--define-derived-type (name expander predicate &optional parents) "Register derived type with NAME for method dispatching. EXPANDER is the function that computes the type specifier from the arguments passed to the derived type. +PREDICATE is the precomputed function to test this type when used as an +atomic type, or nil if it cannot be used as an atomic type. PARENTS is a list of types NAME is a subtype of, or nil." (let* ((class (cl--find-class name))) (when class @@ -509,6 +511,8 @@ PARENTS is a list of types NAME is a subtype of, or nil." (cl--derived-type-class-make name (function-documentation expander) parents)) (define-symbol-prop name 'cl-deftype-handler expander) + (when predicate + (define-symbol-prop name 'cl-deftype-satisfies predicate)) ;; Record new type. The constructor of the class ;; `cl-type-class' already ensures that parent types must be ;; defined before their "child" types (i.e. already added to @@ -530,7 +534,7 @@ PARENTS is a list of types NAME is a subtype of, or nil." (or (memq name cl--derived-type-list) ;; Exclude types that can't be used without arguments. ;; They'd signal errors in `cl-types-of'! - (not (ignore-errors (funcall expander))) + (not predicate) (push name cl--derived-type-list)))) ;; Make sure functions defined with cl-defsubst can be inlined even in -- 2.39.5