1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-06 14:30:50 -08:00

cl-typep: Emit warning when using a type not known to be a type

`cl-typep` has used a heuristic that if there's a `<foo>-p` function,
then <foo> can be used as a type.  This made sense in the past where
most types were not officially declared to be (cl-)types, but nowadays
this just encourages abuses such as using `cl-typecase` with
"types" like `fbound`.  It's also a problem for EIEIO objects, where
for historical reasons `<foo>-p` tests if the object is of type
exactly `<foo>` whereas (cl-typep OBJ <foo>) should instead test
if OBJ is a *subtype* of `<foo>`.

So we change `cl-typep` to emit a warning whenever this "-p" heuristic
is used, to discourage abuses, encourage the use of explicit
`cl-deftype` declarations, and try and detect some misuses of
`<foo>-p` for EIEIO objects.

* lisp/emacs-lisp/eieio.el (defclass): Define as type not only at
run-time but also for the current compilation unit.

* lisp/emacs-lisp/eieio-core.el (class, eieio-object): Define as types.

* lisp/emacs-lisp/cl-preloaded.el (cl-struct-define): Don't abuse the
"-p" heuristic.

* lisp/emacs-lisp/cl-macs.el (cl-deftype-satisfies):
Add entries for frames, windows, markers, and overlays.
(cl-typep): Emit a warning when using a predicate that is not known to
correspond to a type.

* lisp/files.el (file-relative-name): Fix error that can trigger if
there's an(other) error between loading `files.el` and loading
`minibuffer.el`.
This commit is contained in:
Stefan Monnier 2022-06-06 00:04:00 -04:00
parent b90d2a6a63
commit 5ee4209f30
5 changed files with 32 additions and 13 deletions

View file

@ -3412,19 +3412,23 @@ Of course, we really can't know that for sure, so it's just a heuristic."
(cons . consp) (cons . consp)
(fixnum . fixnump) (fixnum . fixnump)
(float . floatp) (float . floatp)
(frame . framep)
(function . functionp) (function . functionp)
(integer . integerp) (integer . integerp)
(keyword . keywordp) (keyword . keywordp)
(list . listp) (list . listp)
(marker . markerp)
(natnum . natnump) (natnum . natnump)
(number . numberp) (number . numberp)
(null . null) (null . null)
(overlay . overlayp)
(real . numberp) (real . numberp)
(sequence . sequencep) (sequence . sequencep)
(subr . subrp) (subr . subrp)
(string . stringp) (string . stringp)
(symbol . symbolp) (symbol . symbolp)
(vector . vectorp) (vector . vectorp)
(window . windowp)
;; FIXME: Do we really want to consider this a type? ;; FIXME: Do we really want to consider this a type?
(integer-or-marker . integer-or-marker-p) (integer-or-marker . integer-or-marker-p)
)) ))
@ -3475,6 +3479,8 @@ Of course, we really can't know that for sure, so it's just a heuristic."
(inline-quote (funcall #',(get type 'cl-deftype-satisfies) ,val))) (inline-quote (funcall #',(get type 'cl-deftype-satisfies) ,val)))
((and (or 'nil 't) type) (inline-quote ',type)) ((and (or 'nil 't) type) (inline-quote ',type))
((and (pred symbolp) type) ((and (pred symbolp) type)
(macroexp-warn-and-return
(format-message "Unknown type: %S" type)
(let* ((name (symbol-name type)) (let* ((name (symbol-name type))
(namep (intern (concat name "p")))) (namep (intern (concat name "p"))))
(cond (cond
@ -3483,8 +3489,9 @@ Of course, we really can't know that for sure, so it's just a heuristic."
(setq namep (intern (concat name "-p")))) (setq namep (intern (concat name "-p"))))
(inline-quote (funcall #',namep ,val))) (inline-quote (funcall #',namep ,val)))
((cl--macroexp-fboundp type) (inline-quote (funcall #',type ,val))) ((cl--macroexp-fboundp type) (inline-quote (funcall #',type ,val)))
(t (error "Unknown type %S" type))))) (t (error "Unknown type %S" type))))
(type (error "Bad type spec: %s" type))))) nil nil type))
(type (error "Bad type spec: %S" type)))))
;;;###autoload ;;;###autoload

View file

@ -152,7 +152,7 @@ supertypes from the most specific to least specific.")
;;;###autoload ;;;###autoload
(defun cl-struct-define (name docstring parent type named slots children-sym (defun cl-struct-define (name docstring parent type named slots children-sym
tag print) tag print)
(cl-check-type name cl--struct-name) (cl-check-type name (satisfies cl--struct-name-p))
(unless type (unless type
;; Legacy defstruct, using tagged vectors. Enable backward compatibility. ;; Legacy defstruct, using tagged vectors. Enable backward compatibility.
(cl-old-struct-compat-mode 1)) (cl-old-struct-compat-mode 1))

View file

@ -137,6 +137,8 @@ Currently under control of this var:
X can also be is a symbol." X can also be is a symbol."
(eieio--class-p (if (symbolp x) (cl--find-class x) x))) (eieio--class-p (if (symbolp x) (cl--find-class x) x)))
(cl-deftype class () `(satisfies class-p))
(defun eieio--class-print-name (class) (defun eieio--class-print-name (class)
"Return a printed representation of CLASS." "Return a printed representation of CLASS."
(format "#<class %s>" (eieio-class-name class))) (format "#<class %s>" (eieio-class-name class)))
@ -165,6 +167,8 @@ Return nil if that option doesn't exist."
(and (recordp obj) (and (recordp obj)
(eieio--class-p (eieio--object-class obj)))) (eieio--class-p (eieio--object-class obj))))
(cl-deftype eieio-object () `(satisfies eieio-object-p))
(define-obsolete-function-alias 'object-p #'eieio-object-p "25.1") (define-obsolete-function-alias 'object-p #'eieio-object-p "25.1")
(defun class-abstract-p (class) (defun class-abstract-p (class)

View file

@ -271,7 +271,8 @@ This method is obsolete."
;; test, so we can let typep have the CLOS documented behavior ;; test, so we can let typep have the CLOS documented behavior
;; while keeping our above predicate clean. ;; while keeping our above predicate clean.
(define-symbol-prop ',name 'cl-deftype-satisfies #',testsym2) (eval-and-compile
(define-symbol-prop ',name 'cl-deftype-satisfies #',testsym2))
(eieio-defclass-internal ',name ',superclasses ',slots ',options-and-doc) (eieio-defclass-internal ',name ',superclasses ',slots ',options-and-doc)

View file

@ -5354,7 +5354,14 @@ on a DOS/Windows machine, it returns FILENAME in expanded form."
(let ((fremote (file-remote-p filename)) (let ((fremote (file-remote-p filename))
(dremote (file-remote-p directory)) (dremote (file-remote-p directory))
(fold-case (or (file-name-case-insensitive-p filename) (fold-case (or (file-name-case-insensitive-p filename)
read-file-name-completion-ignore-case))) ;; During bootstrap, it can happen that
;; `read-file-name-completion-ignore-case' is
;; not defined yet.
;; FIXME: `read-file-name-completion-ignore-case' is
;; a user-config which we shouldn't trust to reflect
;; the actual file system's semantics.
(and (boundp 'read-file-name-completion-ignore-case)
read-file-name-completion-ignore-case))))
(if ;; Conditions for separate trees (if ;; Conditions for separate trees
(or (or
;; Test for different filesystems on DOS/Windows ;; Test for different filesystems on DOS/Windows