From: Stefan Monnier Date: Tue, 26 Mar 2024 17:14:15 +0000 (-0400) Subject: cl-preloaded.el: Fix the type lattice X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=6a695e14a1bf32d1733a7decb9263da8355ad74e;p=emacs.git cl-preloaded.el: Fix the type lattice We generally want types to form not just a DAG but a lattice. If objects can be both `keyword` and `symbol-with-pos`, this means there should be a more precise type describing this intersection. If we ever find the need for such a refinement, we could add such a `keyword-with-pos` type, but here I took the simpler route of treating `keyword` not as a proper built-in type but as a second-class type like `natnum`. While fixing this problem, also fix the problem we had where `functionp` was not quite adequate to characterize objects of type `function`, by introducing a new predicate `cl-functionp` for that. * lisp/emacs-lisp/cl-preloaded.el (cl-functionp): New function. (function): Use it. (keyword): Don't declare it as a built-in type. (user-ptrp): Remove redundant declaration. * lisp/emacs-lisp/cl-generic.el (cl--generic--unreachable-types): Delete constant. (cl-generic-generalizers): Remove corresponding test. * lisp/emacs-lisp/cl-macs.el (cl-deftype-satisfies): Add entry for `keyword` type. * lisp/emacs-lisp/comp.el (comp-known-predicates): Fix type for negative result of `characterp`. Remove duplicate `numberp` entry. Fix types for `keywordp` now that `keyword` is not a built-in type any more. * test/src/data-tests.el (data-tests--cl-type-of): Add a few cases. Remove workaround for `function`. (cherry picked from commit 004f2493a542dd0b804a30e97fc612884ca440f4) --- diff --git a/etc/NEWS b/etc/NEWS index 189656a6afe..9e213fab820 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1840,9 +1840,11 @@ This function is like 'type-of' except that it sometimes returns a more precise type. For example, for nil and t it returns 'null' and 'boolean' respectively, instead of just 'symbol'. -** New function `primitive-function-p`. -This is like `subr-primitive-p` except that it returns t only if the -argument is a function rather than a special-form. +** New functions `primitive-function-p` and `cl-functionp`. +`primitive-function-p` is like `subr-primitive-p` except that it returns +t only if the argument is a function rather than a special-form, +and `cl-functionp` is like `functionp` except it return nil +for lists and symbols. ** Built-in types have now corresponding classes. At the Lisp level, this means that things like (cl-find-class 'integer) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index ee792e505b2..248fd8b7d57 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -1332,11 +1332,6 @@ These match if the argument is `eql' to VAL." ;;; Dispatch on "normal types". -(defconst cl--generic--unreachable-types - ;; FIXME: Try to make that list empty? - '(keyword) - "Built-in classes on which we cannot dispatch for technical reasons.") - (defun cl--generic-type-specializers (tag &rest _) (and (symbolp tag) (let ((class (cl--find-class tag))) @@ -1350,14 +1345,12 @@ These match if the argument is `eql' to VAL." (cl-defmethod cl-generic-generalizers :extra "typeof" (type) "Support for dispatch on types. This currently works for built-in types and types built on top of records." - ;; FIXME: Add support for other types accepted by `cl-typep' such - ;; as `character', `face', `function', ... + ;; FIXME: Add support for other "types" accepted by `cl-typep' such + ;; as `character', `face', `keyword', ...? (or (and (symbolp type) (not (eq type t)) ;; Handled by the `t-generalizer'. (let ((class (cl--find-class type))) - (when (memq type cl--generic--unreachable-types) - (error "Dispatch on %S is currently not supported" type)) (memq (type-of class) '(built-in-class cl-structure-class eieio--class))) (list cl--generic-typeof-generalizer)) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index ab31946d8ab..051cd992fc1 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3467,6 +3467,7 @@ Of course, we really can't know that for sure, so it's just a heuristic." '((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. )) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 35a8d79a1cd..6128db05c61 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -349,6 +349,14 @@ The `slots' (and hence `index-table') are currently unused." ;; so the DAG of OClosure types is "orthogonal" to the distinction ;; between interpreted and compiled functions. +(defun cl-functionp (object) + "Return non-nil if OBJECT is a member of type `function'. +This is like `functionp' except that it returns nil for all lists and symbols, +regardless if `funcall' would accept to call them." + (memq (cl-type-of object) + '(primitive-function subr-native-elisp module-function + interpreted-function byte-code-function))) + (cl--define-built-in-type t nil "Abstract supertype of everything.") (cl--define-built-in-type atom t "Abstract supertype of anything but cons cells." :predicate atom) @@ -356,11 +364,9 @@ The `slots' (and hence `index-table') are currently unused." (cl--define-built-in-type tree-sitter-compiled-query atom) (cl--define-built-in-type tree-sitter-node atom) (cl--define-built-in-type tree-sitter-parser atom) -(declare-function user-ptrp "data.c") (when (fboundp 'user-ptrp) (cl--define-built-in-type user-ptr atom nil - ;; FIXME: Shouldn't it be called - ;; `user-ptr-p'? + ;; FIXME: Shouldn't it be called `user-ptr-p'? :predicate user-ptrp)) (cl--define-built-in-type font-object atom) (cl--define-built-in-type font-entity atom) @@ -410,8 +416,6 @@ The `slots' (and hence `index-table') are currently unused." 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 keyword (symbol) - "Type of those symbols whose first char is `:'.") (cl--define-built-in-type boolean (symbol) "Type of the canonical boolean values, i.e. either nil or t.") (cl--define-built-in-type symbol-with-pos (symbol) @@ -431,7 +435,8 @@ For this build of Emacs it's %dbit." ;; Example of slots we could document. (car car) (cdr cdr)) (cl--define-built-in-type function (atom) - "Abstract supertype of function values.") + "Abstract supertype of function values." + :predicate cl-functionp) (cl--define-built-in-type compiled-function (function) "Abstract type of functions that have been compiled.") (cl--define-built-in-type byte-code-function (compiled-function) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 03ed232a9d5..e5262e11d61 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -193,13 +193,14 @@ Useful to hook into pass checkers.") ;; cl-macs.el. We can't use `cl-deftype-satisfies' directly as the ;; relation type <-> predicate is not bijective (bug#45576). (defconst comp-known-predicates + ;; FIXME: Auto-generate (most of) it from `cl-deftype-satifies'? '((arrayp array) (atom atom) (bool-vector-p bool-vector) (booleanp boolean) (bufferp buffer) (char-table-p char-table) - (characterp fixnum) + (characterp fixnum t) (consp cons) (floatp float) (framep frame) @@ -207,14 +208,13 @@ Useful to hook into pass checkers.") (hash-table-p hash-table) (integer-or-marker-p integer-or-marker) (integerp integer) - (keywordp keyword) + (keywordp symbol t) (listp list) (markerp marker) (natnump (integer 0 *)) (null null) (number-or-marker-p number-or-marker) (numberp number) - (numberp number) (obarrayp obarray) (overlayp overlay) (processp process) diff --git a/test/src/data-tests.el b/test/src/data-tests.el index daa49e671b5..753d74c02ec 100644 --- a/test/src/data-tests.el +++ b/test/src/data-tests.el @@ -845,10 +845,12 @@ comparing the subr with a much slower Lisp implementation." ;; Note: This doesn't work for list/vector structs since those types ;; are too difficult/unreliable to detect (so `cl-type-of' only says ;; it's a `cons' or a `vector'). - (dolist (val (list -2 10 (expt 2 128) nil t 'car + (dolist (val (list -2 10 (expt 2 128) nil t 'car :car (symbol-function 'car) (symbol-function 'progn) - (position-symbol 'car 7))) + (eval '(lambda (x) (+ x 1)) t) + (position-symbol 'car 7) + (position-symbol :car 7))) (let* ((type (cl-type-of val)) (class (cl-find-class type)) (alltypes (cl--class-allparents class)) @@ -858,19 +860,17 @@ comparing the subr with a much slower Lisp implementation." (dolist (parent alltypes) (should (cl-typep val parent)) (dolist (subtype (cl--class-children (cl-find-class parent))) - (unless (memq subtype alltypes) - (unless (memq subtype - ;; FIXME: Some types don't have any associated - ;; predicate, - '( font-spec font-entity font-object - finalizer condvar terminal - native-comp-unit interpreted-function - tree-sitter-compiled-query - tree-sitter-node tree-sitter-parser - ;; `functionp' also matches things of type - ;; `symbol' and `cons'. - function)) - (should-not (cl-typep val subtype))))))))) + (when (and (not (memq subtype alltypes)) + (built-in-class-p (cl-find-class subtype)) + (not (memq subtype + ;; FIXME: Some types don't have any associated + ;; predicate, + '( font-spec font-entity font-object + finalizer condvar terminal + native-comp-unit interpreted-function + tree-sitter-compiled-query + tree-sitter-node tree-sitter-parser)))) + (should-not (cl-typep val subtype)))))))) ;;; data-tests.el ends here