From: Stefan Monnier Date: Mon, 28 Apr 2025 19:47:46 +0000 (-0400) Subject: lisp/emacs-lisp/cl-types.el: New file X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=3438c58a80bb2d60be94429b3180c96d8db6b227;p=emacs.git lisp/emacs-lisp/cl-types.el: New file * test/lisp/emacs-lisp/cl-types-tests.el: Also, new file. (cherry picked from commit dfbeb7478ecd817f888927154858c380fb60390f) --- diff --git a/lisp/emacs-lisp/cl-types.el b/lisp/emacs-lisp/cl-types.el new file mode 100644 index 00000000000..0a384e09d79 --- /dev/null +++ b/lisp/emacs-lisp/cl-types.el @@ -0,0 +1,278 @@ +;; -*- lexical-binding: t; -*- + +;; Data types defined by `cl-deftype' are now recognized as argument +;; types for dispatching generic functions methods. + +;; Will be removed when included in cl-lib. +(require 'cl-lib) +(eval-when-compile (require 'cl-macs)) ;For cl--find-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 + "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)) + +(defun cl--type-dag () + "Return a DAG from the list of defined types." + (mapcar (lambda (type) (cl--type-parents type)) cl--type-list)) + +;; 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))) + +(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 ((oldtlist (copy-sequence cl--type-list)) + (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)) + (if recorded + ;; Clear any previous error mark. + (cl-remprop name 'cl--type-error) + ;; Record new type to include its dependency in the DAG. + (push name cl--type-list)) + ;; `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 + (cl--type-dag) + (lambda (_) (error "Invalid dependency graph"))))) + (error + ;; On error restore previous data. + (setq cl--type-list oldtlist) + (setf (symbol-plist name) oldplist) + (error (format "Define %S failed: %s" + name (error-message-string err))))))) + +;;;###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)))) + (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))) + `(eval-and-compile ;;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)))))) + +;; Ensure each type satisfies `eql'. +(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." + (put type 'cl--type-error error) ;; Mark TYPE as in-error. + ;; Temporarily raise the recursion limit to avoid another recursion + ;; error while reporting ERROR. + (let ((max-lisp-eval-depth (+ 800 max-lisp-eval-depth))) + (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 +;; 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) + "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 ((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, if it previously produced an error. + (null (get type 'cl--type-error)) + ;; 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 its parents to the DAG. + (condition-case e + (cl-typep object type) + (error (cl--type-error type e))) + ;; (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))) + +;;; 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))) + +(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 new file mode 100644 index 00000000000..f247ddd89d9 --- /dev/null +++ b/test/lisp/emacs-lisp/cl-types-tests.el @@ -0,0 +1,93 @@ +;;; 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 + (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 (equal '(multiples-of-3 multiples-of-4 multiples-of-2) + (seq-intersection (cl-types-of 12) types))) + + (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