Package: emacs;
Reported by: David Ponce <da_vid <at> orange.fr>
Date: Fri, 11 Apr 2025 07:16:01 UTC
Severity: normal
Found in version 31.0.50
Message #170 received at 77725 <at> debbugs.gnu.org (full text, mbox):
From: Stefan Monnier <monnier <at> iro.umontreal.ca> To: David Ponce <da_vid <at> orange.fr> Cc: 77725 <at> debbugs.gnu.org, Eli Zaretskii <eliz <at> gnu.org> Subject: Re: bug#77725: 31.0.50; Add support for types accepted by `cl-typep' to cl-generic? Date: Mon, 05 May 2025 14:59:28 -0400
[Message part 1 (text/plain, inline)]
>> Thanks, pushed to the branch. I think the code is looking pretty good now.
> Thank you, that's great!
I just pushed to the branch a further patch (see attached) which tries
to simplify the code a bit more.
Stefan
[cl-types.patch (text/x-diff, inline)]
commit 68a50324a70bd794d7f3228290310093f1515f7b
Author: Stefan Monnier <monnier <at> iro.umontreal.ca>
Date: Mon May 5 14:57:05 2025 -0400
cl-types: Simplify a bit further
Mostly, get rid of `cl--type-flag` and rely only on the presence/absence
of the type on `cl--types-list` to "flag" erroring-types.
Also, don't try and catch errors during dispatch.
* lisp/emacs-lisp/cl-types.el (cl--type-dispatch-list): Move to the
relevant section.
(cl--type-parents): Inline into sole caller.
(cl--type-deftype): Add `arglist` argument.
Don't signal an error if the type already existed but wasn't in
`cl--type-list` since that's normal and we can fix it.
Don't touch `cl--type-flag` any more.
Don't add to `cl--type-list` if it can't be used without arguments.
(cl-deftype2): Adjust call accordingly.
(cl--type-error): Inline into sole caller.
(cl-types-of): Be more careful to preserve ordering of types
before passing them to `merge-ordered-lists`.
Add `types` argument for use by dispatch.
Don't bother skipping the `root-type` since that's a built-in type,
so it should never happen anyway.
Don't catch errors if called from dispatch.
Don't bother with `cl--type-flag`.
(cl--type-generalizer): Use new arg of `cl-types-of` instead of
let-binding `cl--type-list`, in case `cl-types-of` ends up (auto)loading
a file or some such thing which needs to use/modify `cl--type-list`.
(cl--type-undefine): Move to end of file.
* test/lisp/emacs-lisp/cl-types-tests.el (cl-types-test): Remove DAG
test since we don't detect such errors any more.
Relax ordering test when the order is not guaranteed
by parent-relationships.
diff --git a/lisp/emacs-lisp/cl-types.el b/lisp/emacs-lisp/cl-types.el
index b7816ca3a84..a466c309a33 100644
--- a/lisp/emacs-lisp/cl-types.el
+++ b/lisp/emacs-lisp/cl-types.el
@@ -22,9 +22,6 @@
(defvar cl--type-list nil
"Precedence list of the defined cl-types.")
-(defvar cl--type-dispatch-list nil
- "List of types that need to be checked during dispatch.")
-
;; FIXME: The `cl-deftype-handler' property should arguably be turned
;; into a field of this struct (but it has performance and
;; compatibility implications, so let's not make that change for now).
@@ -51,71 +48,44 @@ cl--type-p
That is, a type defined by `cl-deftype', of class `cl-type-class'."
(and (symbolp object) (cl-type-class-p (cl--find-class object))))
-(defun cl--type-parents (name)
- "Get parents of type with NAME.
-NAME is a symbol representing a type.
-Return a possibly empty list of types."
- (cl--class-allparents (cl--find-class name)))
-
-;; Keep it for now, for testing.
-(defun cl--type-undefine (name)
- "Remove the definition of cl-type with NAME.
-NAME is an unquoted symbol representing a cl-type.
-Signal an error if NAME has subtypes."
- (cl-check-type name (satisfies cl--type-p))
- (when-let* ((children (cl--class-children (cl--find-class name))))
- (error "Type has children: %S" children))
- (cl-remprop name 'cl--type-flag)
- (cl-remprop name 'cl--class)
- (cl-remprop name 'cl-deftype-handler)
- (setq cl--type-dispatch-list (delq name cl--type-dispatch-list))
- (setq cl--type-list (delq name cl--type-list)))
-
-(defun cl--type-deftype (name parents &optional docstring)
- ;; FIXME: Should we also receive the arglist?
+(defun cl--type-deftype (name parents arglist &optional docstring)
"Register cl-type with NAME for method dispatching.
PARENTS is a list of types NAME is a subtype of, or nil.
DOCSTRING is an optional documentation string."
- (condition-case err
- (let* ((class (cl--find-class name))
- (recorded (memq name cl--type-list)))
- (if (null class)
- (or (null recorded)
- (error "Type registered, but doesn't exist"))
- (or recorded (error "Type exists, but not registered"))
- (or (cl-type-class-p class)
- ;; FIXME: We have some uses `cl-deftype' in Emacs that
- ;; "complement" another declaration of the same type,
- ;; so maybe we should turn this into a warning (and
- ;; not overwrite the `cl--find-class' in that case)?
- (error "Type in another class: %S" (type-of class))))
- ;; Setup a type descriptor for NAME.
- (setf (cl--find-class name)
- (cl--type-class-make name docstring parents))
- ;; Reset NAME as a newly defined type.
- (cl-remprop name 'cl--type-flag)
- ;; 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
- ;; the `cl--type-list' for types defined with `cl-deftype').
- ;; So it is enough to simply push a new type at the beginning
- ;; of the list.
- ;; Redefinition is more complicated, because child types may
- ;; be in the list, so moving the type to the head can be
- ;; incorrect. The "cheap" solution is to leave the list
- ;; unchanged (and hope the redefinition doesn't change the
- ;; hierarchy too much).
- ;; Side note: Redefinitions introduce other problems as well
- ;; because the class object's `parents` slot contains
- ;; references to `cl--class` objects, so after a redefinition
- ;; via (setf (cl--find-class FOO) ...), the children's
- ;; `parents` slots point to the old class object. That's a
- ;; problem that affects all types and that we don't really try
- ;; to solve currently.
- (or recorded (push name cl--type-list)))
- (error
- (error (format "Define %S failed: %s"
- name (error-message-string err))))))
+ (let* ((class (cl--find-class name)))
+ (when class
+ (or (cl-type-class-p class)
+ ;; FIXME: We have some uses `cl-deftype' in Emacs that
+ ;; "complement" another declaration of the same type,
+ ;; so maybe we should turn this into a warning (and
+ ;; not overwrite the `cl--find-class' in that case)?
+ (error "Type in another class: %S" (type-of class))))
+ ;; Setup a type descriptor for NAME.
+ (setf (cl--find-class name)
+ (cl--type-class-make name docstring parents))
+ ;; 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
+ ;; the `cl--type-list' for types defined with `cl-deftype').
+ ;; So it is enough to simply push a new type at the beginning
+ ;; of the list.
+ ;; Redefinition is more complicated, because child types may
+ ;; be in the list, so moving the type to the head can be
+ ;; incorrect. The "cheap" solution is to leave the list
+ ;; unchanged (and hope the redefinition doesn't change the
+ ;; hierarchy too much).
+ ;; Side note: Redefinitions introduce other problems as well
+ ;; because the class object's `parents` slot contains
+ ;; references to `cl--class` objects, so after a redefinition
+ ;; via (setf (cl--find-class FOO) ...), the children's
+ ;; `parents` slots point to the old class object. That's a
+ ;; problem that affects all types and that we don't really try
+ ;; to solve currently.
+ (or (memq name cl--type-list)
+ ;; Exclude types that can't be used without arguments.
+ ;; They'd signal errors in `cl-types-of'!
+ (not (memq (car arglist) '(nil &rest &optional &keys)))
+ (push name cl--type-list))))
;;;###autoload
(defmacro cl-deftype2 (name arglist &rest body)
@@ -170,7 +140,7 @@ cl-deftype2
;; 'cl-lib)), so `cl--type-deftype' needs to go either to
;; `cl-preloaded.el' or it should be autoloaded even when
;; `cl-lib' is not loaded.
- (cl--type-deftype ',name ',parents ,docstring)
+ (cl--type-deftype ',name ',parents ',arglist ,docstring)
(define-symbol-prop ',name 'cl-deftype-handler
(cl-function
(lambda (&cl-defs ('*) ,@arglist)
@@ -181,17 +151,6 @@ cl-deftype2
(defvar cl--type-unique (make-hash-table :test 'equal)
"Record an unique value of each type.")
-(defun cl--type-error (type error)
- "Mark TYPE as in-error, and report the produced ERROR value."
- ;; Temporarily raise the recursion limit to avoid another recursion
- ;; error while reporting ERROR.
- (let ((max-lisp-eval-depth (+ 800 max-lisp-eval-depth)))
- ;; Mark TYPE as in-error and remove it from the dispatch list.
- (put type 'cl--type-flag 'error)
- (setq cl--type-dispatch-list (delq type cl--type-dispatch-list))
- (warn "cl-types-of %s, %s" type (error-message-string error)))
- nil)
-
;; FIXME: `cl-types-of' CPU cost is proportional to the number of types
;; defined with `cl-deftype', so the more popular it gets, the slower
;; it becomes. And of course, the cost of each type check is
@@ -234,59 +193,54 @@ cl--type-error
;; - in `cl-types-of' start by calling `cl-type-of', then use the map
;; to find which cl-types may need to be checked.
;;
-(defun cl-types-of (object)
-"Return the types OBJECT belongs to.
+(defun cl-types-of (object &optional types)
+ "Return the types OBJECT belongs to.
Return an unique list of types OBJECT belongs to, ordered from the
-most specific type to the most general."
-(let* ((root-type (cl-type-of object))
- (found (list root-type)))
- ;; Build a list of all types OBJECT belongs to.
- (dolist (type cl--type-list)
- (let ((flag (get type 'cl--type-flag)))
+most specific type to the most general.
+TYPES is an internal argument."
+ (let* ((found nil))
+ ;; Build a list of all types OBJECT belongs to.
+ (dolist (type (or types cl--type-list))
(and
- ;; Skip type, if it previously produced an error.
- (not (eq flag 'error))
- ;; Skip type which we are sure will not match.
- (or (null flag) (eq flag root-type))
;; If OBJECT is of type, add type to the matching list.
- (condition-case-unless-debug e
+ (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)
- (error (cl--type-error type e)))
- (or flag (put type 'cl--type-flag root-type))
- (push type found))))
- ;; Return an unique value of the list of types OBJECT belongs to,
- ;; which is also the list of specifiers for OBJECT.
- (with-memoization (gethash found cl--type-unique)
- ;; Compute an ordered list of types from the DAG.
- (merge-ordered-lists (mapcar #'cl--type-parents found)))))
+ (condition-case-unless-debug e
+ (cl-typep object type)
+ (error (setq cl--type-list (delq type cl--type-list))
+ (warn "cl-types-of %S: %s"
+ type (error-message-string e)))))
+ (push type found)))
+ (push (cl-type-of object) found)
+ ;; Return an unique value of the list of types OBJECT belongs to,
+ ;; which is also the list of specifiers for OBJECT.
+ (with-memoization (gethash found cl--type-unique)
+ ;; Compute an ordered list of types from the DAG.
+ (merge-ordered-lists
+ (mapcar (lambda (type) (cl--class-allparents (cl--find-class type)))
+ (nreverse found))))))
;;; Method dispatching
;;
-;; For a declaration like
-;;
-;; (cl-deftype list-of (elem-type)
-;; `(and list
-;; (satisfies ,(lambda (list)
-;; (cl-every (lambda (elem)
-;; (cl-typep elem elem-type))
-;; list)))))
-;;
-;; we add the type to `cl--type-list' even though it's unusable there
-;; (the `cl-typep` call in `cl-types-of' will always signal an error
-;; because the type can't be used without argument).
-;;
-;; One way to solve this (and even open up the possibility to
-;; dispatch on complex types like `(list-of FOO)') is to populate
-;; `cl--type-dispatch-list' (i.e. the list of types that need to
-;; be checked during dispatch) from `cl-generic-generalizers' so it
-;; includes only those types for which there's a method, rather than
-;; all defined types.
+(defvar cl--type-dispatch-list nil
+ "List of types that need to be checked during dispatch.")
(cl-generic-define-generalizer cl--type-generalizer
+ ;; FIXME: This priority can't be always right. :-(
+ ;; E.g. a method dispatching on a type like (or number function),
+ ;; should take precedence over a method on `t' but not over a method
+ ;; on `number'. Similarly a method dispatching on a type like
+ ;; (satisfies (lambda (x) (equal x '(A . B)))) should take precedence
+ ;; over a method on (head 'A).
+ ;; Fixing this 100% is impossible so this generalizer is condemned to
+ ;; suffer from "undefined method ordering" problems, unless/until we
+ ;; restrict it somehow to a subset that we can handle reliably.
20 ;; "typeof" < "cl-types-of" < "head" priority
- (lambda (obj &rest _) `(let ((cl--type-list cl--type-dispatch-list))
- (cl-types-of ,obj)))
+ (lambda (obj &rest _) `(cl-types-of ,obj cl--type-dispatch-list))
(lambda (tag &rest _) (if (consp tag) tag)))
(cl-defmethod cl-generic-generalizers :extra "cl-types-of" (type)
@@ -296,6 +250,9 @@ cl-generic-generalizers
;; Add a new dispatch type to the dispatch list, then
;; synchronize with `cl--type-list' so that both lists follow
;; the same type precedence order.
+ ;; The `merge-ordered-lists' is `cl-types-of' should we make this
+ ;; ordering unnecessary, but it's still handy for all those types
+ ;; that don't declare their parents.
(unless (memq type cl--type-dispatch-list)
(setq cl--type-dispatch-list
(seq-intersection cl--type-list
@@ -303,6 +260,21 @@ cl-generic-generalizers
(list cl--type-generalizer))
(cl-call-next-method)))
+;;; Support for unloading.
+
+;; Keep it for now, for testing.
+(defun cl--type-undefine (name)
+ "Remove the definition of cl-type with NAME.
+NAME is an unquoted symbol representing a cl-type.
+Signal an error if NAME has subtypes."
+ (cl-check-type name (satisfies cl--type-p))
+ (when-let* ((children (cl--class-children (cl--find-class name))))
+ (error "Type has children: %S" children))
+ (cl-remprop name 'cl--class)
+ (cl-remprop name 'cl-deftype-handler)
+ (setq cl--type-dispatch-list (delq name cl--type-dispatch-list))
+ (setq cl--type-list (delq name cl--type-list)))
+
(provide 'cl-types)
;;; cl-types.el ends here
diff --git a/test/lisp/emacs-lisp/cl-types-tests.el b/test/lisp/emacs-lisp/cl-types-tests.el
index f247ddd89d9..746270578e7 100644
--- a/test/lisp/emacs-lisp/cl-types-tests.el
+++ b/test/lisp/emacs-lisp/cl-types-tests.el
@@ -48,14 +48,15 @@ cl-types-test
"Test types definition, cl-types-of and method dispatching."
;; Invalid DAG error
- (should-error
- (eval
- '(cl-deftype2 unsigned-16bits ()
- "Unsigned 16-bits integer."
- (declare (parents unsigned-8bits))
- '(unsigned-byte 16))
- lexical-binding
- ))
+ ;; FIXME: We don't test that any more.
+ ;; (should-error
+ ;; (eval
+ ;; '(cl-deftype2 unsigned-16bits ()
+ ;; "Unsigned 16-bits integer."
+ ;; (declare (parents unsigned-8bits))
+ ;; '(unsigned-byte 16))
+ ;; lexical-binding
+ ;; ))
;; Test that (cl-types-of 4) is (multiples-of-4 multiples-of-2 ...)
;; Test that (cl-types-of 6) is (multiples-of-3 multiples-of-2 ...)
@@ -70,8 +71,10 @@ cl-types-test
(should (equal '(multiples-of-3 multiples-of-2)
(seq-intersection (cl-types-of 6) types)))
- (should (equal '(multiples-of-3 multiples-of-4 multiples-of-2)
- (seq-intersection (cl-types-of 12) types)))
+ (should (member (seq-intersection (cl-types-of 12) types)
+ ;; Order between 3 and 4/2 is undefined.
+ '((multiples-of-3 multiples-of-4 multiples-of-2)
+ (multiples-of-4 multiples-of-2 multiples-of-3))))
(should (equal '()
(seq-intersection (cl-types-of 5) types)))
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.