mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-01-30 12:21:25 -08:00
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`.
This commit is contained in:
Stefan Monnier
parent
68a50324a7
commit
fc4d8ce951
8 changed files with 373 additions and 368 deletions
|
|
@ -965,6 +965,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
|
||||
;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=77725>).
|
||||
;;
|
||||
;; 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")
|
||||
|
|
|
|||
|
|
@ -560,6 +560,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)))
|
||||
|
|
|
|||
|
|
@ -3786,15 +3786,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.
|
||||
|
||||
(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.
|
||||
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').
|
||||
|
||||
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'.
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=77725>).
|
||||
;;
|
||||
;; 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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
Loading…
Add table
Add a link
Reference in a new issue