From: Stefan Monnier Date: Tue, 6 May 2025 03:18:56 +0000 (-0400) Subject: cl-types: Integrate into CL-Lib X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=1cd3a5aba37855a57523d4213170d822f7254a12;p=emacs.git cl-types: Integrate into CL-Lib * lisp/emacs-lisp/cl-extra.el (cl--type-unique, cl-types-of) (cl--type-dispatch-list, cl--type-generalizer): Move to `cl-extra.el`. (cl--type-generalizers): New function extracted from "cl-types-of" method of `cl-generic-generalizers`. * lisp/emacs-lisp/cl-lib.el (cl-generic-generalizers): New method to dispatch on derived types. Use `cl--type-generalizers`. * lisp/emacs-lisp/cl-macs.el (cl-deftype): Move from `cl-types.el` and rename from `cl-deftype2`. (extended-char): Tweak definition to fix bootstrapping issues. * lisp/emacs-lisp/cl-preloaded.el (cl--type-list, cl-type-class) (cl--type-deftype): Move from `cl-types.el`. * lisp/emacs-lisp/oclosure.el (oclosure): Don't abuse `cl-deftype` to register the predicate function. * test/lisp/emacs-lisp/cl-extra-tests.el: Move tests from `cl-type-tests.el`. (cherry picked from commit fc4d8ce9514dd45ab34dbef6f023347b42ee9fef) --- diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 4c9c5b17a91..6e32623ce0d 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -967,6 +967,127 @@ Outputs to the current buffer." (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold)) (mapc #'cl--describe-class-slot cslots)))) +;;;; Method dispatch on `cl-deftype' types. + +;; Extend `cl-deftype' to define data types which are also valid +;; argument types for dispatching generic function methods (see also +;; ). +;; +;; The main entry points are: +;; +;; - `cl-deftype', that defines new data types. +;; +;; - `cl-types-of', that returns the types an object belongs to. + +;; 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 &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. +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 + ;; 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--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)))))) + +(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 _) `(cl-types-of ,obj cl--type-dispatch-list)) + (lambda (tag &rest _) (if (consp tag) tag))) + +;;;###autoload +(defun cl--type-generalizers (type) + ;; 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 + (cons type cl--type-dispatch-list)))) + (list cl--type-generalizer)) + +;;;; Trailer (make-obsolete-variable 'cl-extra-load-hook "use `with-eval-after-load' instead." "28.1") diff --git a/lisp/emacs-lisp/cl-lib.el b/lisp/emacs-lisp/cl-lib.el index 8694a60d8fa..0d64bb8d172 100644 --- a/lisp/emacs-lisp/cl-lib.el +++ b/lisp/emacs-lisp/cl-lib.el @@ -552,6 +552,19 @@ If ALIST is non-nil, the new pairs are prepended to it." ;; those rare places where we do need it. ) +(static-if (not (fboundp 'cl-defmethod)) + ;; `cl-generic' requires `cl-lib' at compile-time, so `cl-lib' can't + ;; use `cl-defmethod' before `cl-generic' has been compiled. + ;; Also, there is no mechanism to autoload methods, so this can't be + ;; moved to `cl-extra.el'. + nil + (declare-function cl--type-generalizers "cl-extra" (type)) + (cl-defmethod cl-generic-generalizers :extra "cl-types-of" (type) + "Support for dispatch on cl-types." + (if (and (symbolp type) (cl-type-class-p (cl--find-class type))) + (cl--type-generalizers type) + (cl-call-next-method)))) + (defun cl--old-struct-type-of (orig-fun object) (or (and (vectorp object) (> (length object) 0) (let ((tag (aref object 0))) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 6655cd8b178..66e642d5f13 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3736,15 +3736,52 @@ macro that returns its `&whole' argument." ;;;###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." - (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))))) +The type NAME can then be used in `cl-typecase', `cl-check-type', +etc., and to some extent, as method specializer. + +ARGLIST is a Common Lisp argument list of the sort accepted by +`cl-defmacro'. BODY forms should return a type specifier that is equivalent +to the type (see the Info node `(cl)Type Predicates'). -(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. +If there is a `declare' form in BODY, the spec (parents . PARENTS) +can specify a list of types NAME is a subtype of. +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. + +If PARENTS is non-nil, ARGLIST must be nil." + (declare (debug cl-defmacro) (doc-string 3) (indent 2)) + (pcase-let* + ((`(,decls . ,forms) (macroexp-parse-body body)) + (docstring (if (stringp (car decls)) + (car decls) + (cadr (assq :documentation decls)))) + (declares (assq 'declare decls)) + (parent-decl (assq 'parents (cdr declares))) + (parents (cdr parent-decl))) + (when parent-decl + ;; "Consume" the `parents' declaration. + (cl-callf (lambda (x) (delq parent-decl x)) (cdr declares)) + (when (equal declares '(declare)) + (cl-callf (lambda (x) (delq declares x)) decls))) + (and parents arglist + (error "Parents specified, but arglist not empty")) + `(eval-and-compile ;;cl-eval-when (compile load eval) + ;; FIXME: Where should `cl--type-deftype' go? Currently, code + ;; using `cl-deftype' can use (eval-when-compile (require + ;; '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 ',arglist ,docstring) + (define-symbol-prop ',name 'cl-deftype-handler + (cl-function + (lambda (&cl-defs ('*) ,@arglist) + ,@decls + ,@forms)))))) + +(static-if (not (fboundp 'cl--type-deftype)) + 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'. diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index dfea8d6c8e3..0447191bbc7 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -465,6 +465,71 @@ The fields are used as follows: (setf (cl--class-parents (cl--find-class 'cl-structure-object)) (list (cl--find-class 'record)))) +;;;; Support for `cl-deftype'. + +(defvar cl--type-list nil + "Precedence list of the defined cl-types.") + +;; 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-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." + (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)))) + ;; Make sure functions defined with cl-defsubst can be inlined even in ;; packages which do not require CL. We don't put an autoload cookie ;; directly on that function, since those cookies only go to cl-loaddefs. diff --git a/lisp/emacs-lisp/cl-types.el b/lisp/emacs-lisp/cl-types.el index a466c309a33..c265e50f0f2 100644 --- a/lisp/emacs-lisp/cl-types.el +++ b/lisp/emacs-lisp/cl-types.el @@ -1,5 +1,41 @@ ;; -*- lexical-binding: t; -*- +;;; Old Sizes: + +;; % (cd lisp/emacs-lisp/; l cl-*.elc) +;; -rw-r--r-- 1 monnier monnier 68920 5 mai 13:49 cl-generic.elc +;; -rw-r--r-- 1 monnier monnier 41841 5 mai 13:49 cl-preloaded.elc +;; -rw-r--r-- 1 monnier monnier 23037 5 mai 13:58 cl-lib.elc +;; -rw-r--r-- 1 monnier monnier 32664 5 mai 14:14 cl-extra.elc +;; -rw-r--r-- 1 monnier monnier 53769 5 mai 14:14 cl-loaddefs.elc +;; -rw-r--r-- 1 monnier monnier 17921 5 mai 14:14 cl-indent.elc +;; -rw-r--r-- 1 monnier monnier 18295 5 mai 14:14 cl-print.elc +;; -rw-r--r-- 1 monnier monnier 101608 5 mai 14:14 cl-macs.elc +;; -rw-r--r-- 1 monnier monnier 43849 5 mai 14:14 cl-seq.elc +;; -rw-r--r-- 1 monnier monnier 8691 5 mai 18:53 cl-types.elc +;; % + +;;; After the move: + +;; % (cd lisp/emacs-lisp/; l cl-*.elc) +;; -rw-r--r-- 1 monnier monnier 46390 5 mai 23:04 cl-preloaded.elc +;; -rw-r--r-- 1 monnier monnier 68920 5 mai 23:04 cl-generic.elc +;; -rw-r--r-- 1 monnier monnier 23620 5 mai 23:05 cl-lib.elc +;; -rw-r--r-- 1 monnier monnier 54752 5 mai 23:15 cl-loaddefs.elc +;; -rw-r--r-- 1 monnier monnier 17921 5 mai 23:05 cl-indent.elc +;; -rw-r--r-- 1 monnier monnier 34065 5 mai 23:05 cl-extra.elc +;; -rw-r--r-- 1 monnier monnier 18295 5 mai 23:05 cl-print.elc +;; -rw-r--r-- 1 monnier monnier 102581 5 mai 23:05 cl-macs.elc +;; -rw-r--r-- 1 monnier monnier 159 5 mai 23:05 cl-types.elc +;; -rw-r--r-- 1 monnier monnier 43849 5 mai 23:05 cl-seq.elc +;; % + +;; cl-preloaded: +4549 41841 => 46390 +;; cl-lib: + 583 23037 => 23620 +;; cl-macs: + 973 101608 => 102581 +;; cl-extra +1401 32664 => 34065 +;; cl-loaddefs: + 983 53769 => 54752 + ;; Data types defined by `cl-deftype' are now recognized as argument ;; types for dispatching generic functions methods. @@ -9,271 +45,8 @@ (declare-function cl-remprop "cl-extra" (symbol propname)) (declare-function cl--class-children "cl-extra" (class)) -;; Extend `cl-deftype' to define data types which are also valid -;; argument types for dispatching generic function methods (see also -;; ). -;; -;; The main entry points are: -;; -;; - `cl-deftype', that defines new data types. -;; -;; - `cl-types-of', that returns the types an object belongs to. - -(defvar cl--type-list nil - "Precedence list of the defined cl-types.") - -;; 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 cl-type. -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-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." - (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) - "Define NAME as a new data type. -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-deftype2 unsigned-byte (&optional bits) - \"Unsigned integer.\" - (list \\='integer 0 (if (eq bits \\='*) bits (1- (ash 1 bits))))) - - (cl-deftype2 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. - -If PARENTS is non-nil, ARGLIST must be nil." - (declare (debug cl-defmacro) (doc-string 3) (indent 2)) - (pcase-let* - ((`(,decls . ,forms) (macroexp-parse-body body)) - (docstring (if (stringp (car decls)) - (car decls) - (cadr (assq :documentation decls)))) - (declares (assq 'declare decls)) - (parent-decl (assq 'parents (cdr declares))) - (parents (cdr parent-decl))) - (when parent-decl - ;; "Consume" the `parents' declaration. - (cl-callf (lambda (x) (delq parent-decl x)) (cdr declares)) - (when (equal declares '(declare)) - (cl-callf (lambda (x) (delq declares x)) decls))) - (if (memq name parents) - (error "Type in parents: %S" parents)) - (and parents arglist - (error "Parents specified, but arglist not empty")) - `(eval-and-compile ;;cl-eval-when (compile load eval) - ;; FIXME: Where should `cl--type-deftype' go? Currently, code - ;; using `cl-deftype' can use (eval-when-compile (require - ;; '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 ',arglist ,docstring) - (define-symbol-prop ',name 'cl-deftype-handler - (cl-function - (lambda (&cl-defs ('*) ,@arglist) - ,@decls - ,@forms)))))) - -;; 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. -;; -(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. -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 - ;; 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--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 -;; - -(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 _) `(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) - "Support for dispatch on cl-types." - (if (cl--type-p type) - (progn - ;; 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 - (cons type cl--type-dispatch-list)))) - (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) diff --git a/lisp/emacs-lisp/oclosure.el b/lisp/emacs-lisp/oclosure.el index 06d98e6f05a..0f49fc85d87 100644 --- a/lisp/emacs-lisp/oclosure.el +++ b/lisp/emacs-lisp/oclosure.el @@ -151,7 +151,7 @@ (defun oclosure--p (oclosure) (not (not (oclosure-type oclosure)))) -(cl-deftype oclosure () '(satisfies oclosure--p)) +(define-symbol-prop 'oclosure 'cl-deftype-satisfies #'oclosure--p) (defun oclosure--slot-mutable-p (slotdesc) (not (alist-get :read-only (cl--slot-descriptor-props slotdesc)))) diff --git a/test/lisp/emacs-lisp/cl-extra-tests.el b/test/lisp/emacs-lisp/cl-extra-tests.el index 20d1e532a6f..1f94d71e567 100644 --- a/test/lisp/emacs-lisp/cl-extra-tests.el +++ b/test/lisp/emacs-lisp/cl-extra-tests.el @@ -348,4 +348,96 @@ (should (cl-tailp l l)) (should (not (cl-tailp '(4 5) l))))) +;;;; Method dispatch for derived types. + +(cl-deftype multiples-of (&optional m) + (let ((multiplep (if (eq m '*) + #'ignore + (lambda (n) (= 0 (% n m)))))) + `(and integer (satisfies ,multiplep)))) + +(cl-deftype multiples-of-2 () + '(multiples-of 2)) + +(cl-deftype multiples-of-3 () + '(multiples-of 3)) + +(cl-deftype multiples-of-4 () + (declare (parents multiples-of-2)) + '(and multiples-of-2 (multiples-of 4))) + +(cl-deftype unsigned-byte (&optional bits) + "Unsigned integer." + `(integer 0 ,(if (eq bits '*) bits (1- (ash 1 bits))))) + +(cl-deftype unsigned-16bits () + "Unsigned 16-bits integer." + (declare (parents unsigned-byte)) + '(unsigned-byte 16)) + +(cl-deftype unsigned-8bits () + "Unsigned 8-bits integer." + (declare (parents unsigned-16bits)) + '(unsigned-byte 8)) + +(cl-defmethod my-foo ((_n unsigned-byte)) + (format "unsigned")) + +(cl-defmethod my-foo ((_n unsigned-16bits)) + (format "unsigned 16bits - also %s" + (cl-call-next-method))) + +(cl-defmethod my-foo ((_n unsigned-8bits)) + (format "unsigned 8bits - also %s" + (cl-call-next-method))) + +(ert-deftest cl-types-test () + "Test types definition, cl-types-of and method dispatching." + + ;; Invalid DAG error + ;; FIXME: We don't test that any more. + ;; (should-error + ;; (eval + ;; '(cl-deftype 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 ...) + ;; Test that (cl-types-of 12) is (multiples-of-4 multiples-of-3 multiples-of-2 ...) + (let ((types '(multiples-of-2 multiples-of-3 multiples-of-4))) + (should (equal '(multiples-of-2) + (seq-intersection (cl-types-of 2) types))) + + (should (equal '(multiples-of-4 multiples-of-2) + (seq-intersection (cl-types-of 4) types))) + + (should (equal '(multiples-of-3 multiples-of-2) + (seq-intersection (cl-types-of 6) 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))) + ) + + ;;; Method dispatching. + (should (equal "unsigned 8bits - also unsigned 16bits - also unsigned" + (my-foo 100))) + + (should (equal "unsigned 16bits - also unsigned" + (my-foo 256))) + + (should (equal "unsigned" + (my-foo most-positive-fixnum))) + ) + + + ;;; cl-extra-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-types-tests.el b/test/lisp/emacs-lisp/cl-types-tests.el deleted file mode 100644 index 746270578e7..00000000000 --- a/test/lisp/emacs-lisp/cl-types-tests.el +++ /dev/null @@ -1,96 +0,0 @@ -;;; Test `cl-typedef' -*- lexical-binding: t; -*- -;; -(require 'ert) -(require 'cl-types) - -(cl-deftype2 multiples-of (&optional m) - (let ((multiplep (if (eq m '*) - #'ignore - (lambda (n) (= 0 (% n m)))))) - `(and integer (satisfies ,multiplep)))) - -(cl-deftype2 multiples-of-2 () - '(multiples-of 2)) - -(cl-deftype2 multiples-of-3 () - '(multiples-of 3)) - -(cl-deftype2 multiples-of-4 () - (declare (parents multiples-of-2)) - '(and multiples-of-2 (multiples-of 4))) - -(cl-deftype2 unsigned-byte (&optional bits) - "Unsigned integer." - `(integer 0 ,(if (eq bits '*) bits (1- (ash 1 bits))))) - -(cl-deftype2 unsigned-16bits () - "Unsigned 16-bits integer." - (declare (parents unsigned-byte)) - '(unsigned-byte 16)) - -(cl-deftype2 unsigned-8bits () - "Unsigned 8-bits integer." - (declare (parents unsigned-16bits)) - '(unsigned-byte 8)) - -(cl-defmethod my-foo ((_n unsigned-byte)) - (format "unsigned")) - -(cl-defmethod my-foo ((_n unsigned-16bits)) - (format "unsigned 16bits - also %s" - (cl-call-next-method))) - -(cl-defmethod my-foo ((_n unsigned-8bits)) - (format "unsigned 8bits - also %s" - (cl-call-next-method))) - -(ert-deftest cl-types-test () - "Test types definition, cl-types-of and method dispatching." - - ;; Invalid DAG error - ;; 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 ...) - ;; Test that (cl-types-of 12) is (multiples-of-4 multiples-of-3 multiples-of-2 ...) - (let ((types '(multiples-of-2 multiples-of-3 multiples-of-4))) - (should (equal '(multiples-of-2) - (seq-intersection (cl-types-of 2) types))) - - (should (equal '(multiples-of-4 multiples-of-2) - (seq-intersection (cl-types-of 4) types))) - - (should (equal '(multiples-of-3 multiples-of-2) - (seq-intersection (cl-types-of 6) 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))) - ) - - ;;; Method dispatching. - (should (equal "unsigned 8bits - also unsigned 16bits - also unsigned" - (my-foo 100))) - - (should (equal "unsigned 16bits - also unsigned" - (my-foo 256))) - - (should (equal "unsigned" - (my-foo most-positive-fixnum))) - ) - -(provide 'cl-types-tests) - -;;; cl-types-tests.el ends here