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 #83 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: Tue, 22 Apr 2025 17:34:17 -0400
[Message part 1 (text/plain, inline)]
>> Yes, as you've seen, the placement can be tricky. There are bootstrap
>> constraints as well as "general design" desires, and they all kind
>> of pull in different directions.
>> I'll take a closer look and come back with a proposal.
> Great. Thank you!
Sorry for the delay, here's what I came up with.
I added a FIXME about the recursion-breaker which I have a feeling might
not work.
There's also some stylistic problems with the tests:
- We shouldn't test the return value of `cl-deftype`: I don't think it's
documented anywhere and I don't think it's good practice to pay
attention to the return value of declarations.
- They use `eval` too much.
Stefan
[cl-types.patch (text/x-diff, inline)]
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el
index 6390d17a5b7..eb2ad605c8e 100644
--- a/lisp/emacs-lisp/cl-extra.el
+++ b/lisp/emacs-lisp/cl-extra.el
@@ -577,8 +577,8 @@ cl-subseq
,new)))))
(seq-subseq seq start end))
-;;; This isn't a defalias because autoloading defaliases doesn't work
-;;; very well.
+;; This isn't a defalias because autoloading defaliases doesn't work
+;; very well.
;;;###autoload
(defun cl-concatenate (type &rest sequences)
@@ -731,6 +731,213 @@ cl-prettyexpand
(cl-prettyprint form)
(message "")))
+;;; CL type defined via `deftype'.
+
+(defvar cl--type-list nil
+ "List of defined types to lookup for method dispatching.")
+
+;; 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).
+(cl-defstruct
+ (cl-type-class
+ (:include cl--class)
+ (:noinline t)
+ (:constructor nil)
+ (:constructor cl--type-class-make
+ (name
+ docstring
+ parent-types
+ &aux (parents
+ (mapcar
+ (lambda (type)
+ (or (cl--find-class type)
+ (error "Unknown type: %S" type)))
+ parent-types))))
+ (:copier nil))
+ "Type descriptors for types defined by `cl-deftype'.")
+
+(defun cl--type-p (object)
+ "Return non-nil if OBJECT is a used defined type.
+That is, a type of class `cl-type-class'."
+ (and (symbolp object) (cl-type-class-p (cl--find-class object))))
+
+(defmacro cl--type-parents (name)
+ "Get parents of type with NAME.
+NAME is a symbol representing a type."
+ `(cl--class-allparents (cl--find-class ,name)))
+
+(defun cl--type-children (name)
+ "Get children of the type with NAME.
+NAME is a symbol representing a type.
+Return a possibly empty list of types."
+ (cl-check-type name (satisfies cl--type-p))
+ (let (children)
+ (dolist (elt cl--type-list)
+ (or (eq name elt)
+ (if (memq name (cl--type-parents elt))
+ (push elt children))))
+ children))
+
+;; Keep it for now, for testing.
+(defun cl--type-undefine (name)
+ "Remove the definitions of type with NAME.
+NAME is an unquoted symbol representing a type.
+Signal an error if other types inherit from NAME."
+ (declare-function cl-remprop "cl-extra" (symbol propname))
+ (cl-check-type name (satisfies cl--type-p))
+ (when-let* ((children (and (cl--type-p name)
+ (cl--type-children name))))
+ (error "Type has children: %S" children))
+ (cl-remprop name 'cl--class)
+ (cl-remprop name 'cl-deftype-handler)
+ (setq cl--type-list (delq name cl--type-list)))
+
+;;;###autoload
+(defun cl--type-deftype (name parents &optional docstring)
+ "Generalize 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."
+ (let ((oldplist (copy-sequence (symbol-plist name))))
+ (condition-case err
+ (let* ((class (cl--find-class name))
+ (recorded (memq name cl--type-list)))
+ (if (null class)
+ (or (null recorded)
+ (error "Type generalized, but doesn't exist"))
+ (or recorded (error "Type exists, but not generalized"))
+ (or (cl-type-class-p class)
+ (error "Type in another class: %S" (type-of class))))
+ (if (memq name parents)
+ (error "Type in parents: %S" parents))
+ ;; Setup a type descriptor for NAME.
+ (setf (cl--find-class name)
+ (cl--type-class-make name docstring parents))
+ ;; `cl-types-of' iterates through all known types to collect
+ ;; all those an object belongs to, sorted from the most
+ ;; specific type to the more general type. So, keep the
+ ;; global list in this order.
+ (setq cl--type-list
+ (merge-ordered-lists
+ (mapcar (lambda (type)
+ (cl--class-allparents (cl--find-class type)))
+ (if recorded
+ cl--type-list
+ (cons name cl--type-list)))
+ (lambda (_) (error "Invalid dependency graph")))))
+ (error
+ ;; On error restore previous data.
+ (setf (symbol-plist name) oldplist)
+ (error (format "Define %S failed: %s"
+ name (error-message-string err)))))))
+
+(defvar cl--type-object (make-symbol "void"))
+;; Ensure each type satisfies `eql'.
+(defvar cl--type-unique (make-hash-table :test 'equal)
+ "Record an unique value of each type.")
+
+;; 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
+;; unbounded, so a single "expensive" type can slow everything down
+;; further.
+;;
+;; The usual dispatch is
+;;
+;; (lambda (arg &rest args)
+;; (let ((f (gethash (cl-typeof arg) precomputed-methods-table)))
+;; (if f
+;; (apply f arg args)
+;; ;; Slow case when encountering a new type
+;; ...)))
+;;
+;; where often the most expensive part is `&rest' (which has to
+;; allocate a list for those remaining arguments),
+;;
+;; So we're talking about replacing
+;;
+;; &rest + cl-type-of + gethash + if + apply
+;;
+;; with a function that loops over N types, calling `cl-typep' on each
+;; one of them (`cl-typep' itself being a recursive function that
+;; basically interprets the type language). This is going to slow
+;; down dispatch very significantly for those generic functions that
+;; have a method that dispatches on a user defined type, compared to
+;; those that don't.
+;;
+;; A possible further improvement:
+;;
+;; - based on the PARENTS declaration, create a map from builtin-type
+;; to the set of cl-types that have that builtin-type among their
+;; parents. That presumes some PARENTS include some builtin-types,
+;; obviously otherwise the map will be trivial with all cl-types
+;; associated with the `t' "dummy parent". [ We could even go crazy
+;; and try and guess PARENTS when not provided, by analyzing the
+;; type's definition. ]
+;;
+;; - in `cl-types-of' start by calling `cl-type-of', then use the map
+;; to find which cl-types may need to be checked.
+;;
+;;;###autoload
+(defun cl-types-of (object)
+ "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."
+ ;; Ignore recursive call on the same OBJECT, which can legitimately
+ ;; occur when a parent type is checking whether an object's type is
+ ;; that of one of its children.
+ ;; FIXME: Does this even work? Won't `cl--type-object' be rebound to
+ ;; the other object before we get here? IOW wouldn't we need a list
+ ;; of objects that are in the process of being checked? And while
+ ;; returning nil breaks the recursion, won't it return a bogus result?
+ (unless (eq object cl--type-object)
+ (let ((cl--type-object object)
+ (found (list (cl--type-parents (cl-type-of object)))))
+ ;; Build a DAG of all types OBJECT belongs to.
+ (dolist (type cl--type-list)
+ (and
+ ;; Skip type not defined by `cl-deftype'.
+ (cl-type-class-p (cl--find-class type))
+ ;; If BAR is declared as a parent of FOO and `cl-types-of'
+ ;; has already decided that the value is of type FOO, then we
+ ;; already know BAR will be in the output anyway and there's
+ ;; no point testing BAR. So, skip type already selected as
+ ;; parent of another type, assuming that, most of the time,
+ ;; `assq' will be faster than `cl-typep'.
+ (null (assq type found))
+ ;; If OBJECT is of type, add type and parents to the DAG.
+ (cl-typep object type)
+ ;; (dolist (p (cl--type-parents type))
+ ;; (push (cl--type-parents p) found))
+ ;; Equivalent to the `dolist' above, but faster: avoid to
+ ;; recompute several lists of parents we already know.
+ (let ((pl (cl--type-parents type)))
+ (while pl
+ (push pl found)
+ (setq pl (cdr pl))))
+ ))
+ ;; Compute an ordered list of types from the collected DAG.
+ (setq found (merge-ordered-lists found))
+ ;; Return an unique value of this list of types, which is also
+ ;; the list of specifiers for this type.
+ (with-memoization (gethash found cl--type-unique)
+ found))))
+
+(cl-deftype extended-char () '(and character (not base-char)))
+
+;;;; Method dispatching
+
+(cl-generic-define-generalizer cl--type-generalizer
+ 20 ;; "typeof" < "cl-types-of" < "head" priority
+ (lambda (obj &rest _) `(cl-types-of ,obj))
+ (lambda (tag &rest _) (if (consp tag) tag)))
+
+(cl-defmethod cl-generic-generalizers :extra "cl-types-of" (type)
+ "Support for dispatch on types."
+ (if (cl--type-p type)
+ (list cl--type-generalizer)
+ (cl-call-next-method)))
+
;;; Integration into the online help system.
(eval-when-compile (require 'cl-macs)) ;Explicitly, for cl--find-class.
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 8de45626bf0..af38f432e84 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -582,6 +582,7 @@ cl-defmethod
(,'declare-function ,name "")
;; We use #' to quote `name' so as to trigger an
;; obsolescence warning when applicable.
+ ;; FIXME: Eval `eql'and `head' thingies!
(cl-generic-define-method #',name ',(nreverse qualifiers) ',args
',call-con ,fun)))))
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index a966ec5eaf6..1bd3ab55519 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -3786,15 +3786,46 @@ cl--compiler-macro-get
;;;###autoload
(defmacro cl-deftype (name arglist &rest body)
"Define NAME as a new data type.
-The type name can then be used in `cl-typecase', `cl-check-type', etc."
+The type NAME can then be used in `cl-typecase', `cl-check-type', etc,
+and as argument type for dispatching generic function methods.
+
+ARGLIST is a Common Lisp argument list of the sort accepted by
+`cl-defmacro'. BODY forms are evaluated and should return a type
+specifier that is equivalent to the type (see the Info node `(cl) Type
+Predicates' in the GNU Emacs Common Lisp Emulation manual).
+
+If there is a `declare' form in BODY, the spec (parents PARENTS) is
+recognized to specify a list of types NAME is a subtype of. For
+instance:
+
+ (cl-deftype unsigned-byte (&optional bits)
+ \"Unsigned integer.\"
+ (list \\='integer 0 (if (eq bits \\='*) bits (1- (ash 1 bits)))))
+
+ (cl-deftype unsigned-8bits ()
+ \"Unsigned 8-bits integer.\"
+ (declare (parents unsigned-byte))
+ \\='(unsigned-byte 8))
+
+The list of PARENTS types determines the order of methods invocation,
+and missing PARENTS may cause incorrect ordering of methods, while
+extraneous PARENTS may cause use of extraneous methods."
(declare (debug cl-defmacro) (doc-string 3) (indent 2))
- `(cl-eval-when (compile load eval)
- (define-symbol-prop ',name 'cl-deftype-handler
- (cl-function (lambda (&cl-defs ('*) ,@arglist) ,@body)))))
-
-(cl-deftype extended-char () '(and character (not base-char)))
-;; Define fixnum so `cl-typep' recognize it and the type check emitted
-;; by `cl-the' is effective.
+ (pcase-let*
+ ((`(,decls . ,forms) (macroexp-parse-body body))
+ (docstring (if (stringp (car decls))
+ (car decls)
+ (cadr (assq :documentation decls))))
+ (parents (cdr (assq 'parents (cdr (assq 'declare decls))))))
+ (and parents arglist
+ (error "Parents specified, but arglist not empty"))
+ (if docstring (setq forms (cons docstring forms)))
+ `(cl-eval-when (compile load eval)
+ (cl--type-deftype ',name ',parents ,docstring)
+ (define-symbol-prop ',name 'cl-deftype-handler
+ (cl-function
+ (lambda (&cl-defs ('*) ,@arglist)
+ ,@forms))))))
;;; Additional functions that we can now define because we've defined
;;; `cl-defsubst' and `cl-typep'.
diff --git a/test/lisp/emacs-lisp/cl-extra-tests.el b/test/lisp/emacs-lisp/cl-extra-tests.el
index 20d1e532a6f..08198faf28c 100644
--- a/test/lisp/emacs-lisp/cl-extra-tests.el
+++ b/test/lisp/emacs-lisp/cl-extra-tests.el
@@ -348,4 +348,156 @@ cl-extra-test-tailp
(should (cl-tailp l l))
(should (not (cl-tailp '(4 5) l)))))
+(ert-deftest cl-types-test-1 ()
+ "Test types definition and cl-types-of."
+
+ (should
+ (functionp
+ (eval
+ '(cl-deftype multiples-of (&optional m)
+ (let ((multiplep (if (eq m '*)
+ #'ignore
+ (lambda (n) (= 0 (% n m))))))
+ `(and integer (satisfies ,multiplep))))
+ t)))
+
+ (should
+ (functionp
+ (eval
+ '(cl-deftype multiples-of-2 ()
+ '(multiples-of 2))
+ t)))
+
+ (should
+ (functionp
+ (eval
+ '(cl-deftype multiples-of-3 ()
+ '(multiples-of 3))
+ t)))
+
+ (should
+ (functionp
+ (eval
+ '(cl-deftype multiples-of-4 ()
+ (declare (parents multiples-of-2))
+ '(and multiples-of-2 (multiples-of 4)))
+ t)))
+
+ ;; 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 ...)
+ ;; Test that (cl-types-of 12) is (multiples-of-4 multiples-of-3 multiples-of-2 ...)
+ (should
+ (equal
+ (cl-types-of 2)
+ '( multiples-of-2 fixnum integer number integer-or-marker
+ number-or-marker atom t)))
+
+ (should
+ (equal
+ (cl-types-of 4)
+ '( multiples-of-4 multiples-of-2 fixnum integer number
+ integer-or-marker number-or-marker atom t)
+ ))
+
+ (should
+ (equal
+ (cl-types-of 6)
+ '( multiples-of-3 multiples-of-2 fixnum integer number
+ integer-or-marker number-or-marker atom t)
+ ))
+
+ (should
+ (equal
+ (cl-types-of 12)
+ '( multiples-of-3 multiples-of-4 multiples-of-2 fixnum integer
+ number integer-or-marker number-or-marker atom t)
+ ))
+
+ (should
+ (equal
+ (cl-types-of 5)
+ '(fixnum integer number integer-or-marker number-or-marker atom t)
+ ))
+
+ ;; Cleanup
+ (mapc #'cl--type-undefine cl--type-list)
+
+ )
+
+(ert-deftest cl-types-test-2 ()
+ "Test types definition and dispatch."
+
+ (should
+ (functionp
+ (eval
+ '(cl-deftype unsigned-byte (&optional bits)
+ "Unsigned integer."
+ `(integer 0 ,(if (eq bits '*) bits (1- (ash 1 bits)))))
+ t)))
+
+ (should
+ (functionp
+ (eval
+ '(cl-deftype unsigned-16bits ()
+ "Unsigned 16-bits integer."
+ (declare (parents unsigned-byte))
+ '(unsigned-byte 16))
+ t)))
+
+ (should
+ (functionp
+ (eval
+ '(cl-deftype unsigned-8bits ()
+ "Unsigned 8-bits integer."
+ (declare (parents unsigned-16bits))
+ '(unsigned-byte 8))
+ t)))
+
+ ;; Invalid DAG error
+ (should-error
+ (eval
+ '(cl-deftype unsigned-16bits ()
+ "Unsigned 16-bits integer."
+ (declare (parents unsigned-8bits))
+ '(unsigned-byte 16))
+ t))
+
+ (eval
+ '(cl-defmethod my-foo ((_n unsigned-byte))
+ (format "unsigned"))
+ t)
+
+ (eval
+ '(cl-defmethod my-foo ((_n unsigned-16bits))
+ (format "unsigned 16bits - also %s"
+ (cl-call-next-method)))
+ t)
+
+ (eval
+ '(cl-defmethod my-foo ((_n unsigned-8bits))
+ (format "unsigned 8bits - also %s"
+ (cl-call-next-method)))
+ t)
+
+ (should
+ (equal
+ (my-foo 100)
+ "unsigned 8bits - also unsigned 16bits - also unsigned"
+ ))
+
+ (should
+ (equal
+ (my-foo 256)
+ "unsigned 16bits - also unsigned"
+ ))
+
+ (should
+ (equal
+ (my-foo most-positive-fixnum)
+ "unsigned"
+ ))
+ ;; Cleanup
+ (mapc #'cl--type-undefine cl--type-list)
+ )
+
;;; cl-extra-tests.el ends here
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.