;; - `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.")
+ "Precedence list of the defined cl-types.")
+
+(defvar cl--type-dispatch-list nil
+ "List of types that need to be checked during dispatch.")
;; FIXME: The `cl-deftype-handler' property should arguably be turned
;; into a field of this struct (but it has performance and
That is, a type defined by `cl-deftype', of class `cl-type-class'."
(and (symbolp object) (cl-type-class-p (cl--find-class object))))
-(defsubst cl--type-parents (name)
+(defun cl--type-parents (name)
"Get parents of type with NAME.
NAME is a symbol representing a type.
Return a possibly empty list of types."
(cl--class-allparents (cl--find-class name)))
-(defsubst 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--class-children (cl--find-class name)))
-
-(defsubst cl--type-dag (types)
- "Return a DAG from the list of TYPES."
- (mapcar #'cl--type-parents types))
-
;; 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 (and (cl--type-p name)
- (cl--type-children name))))
+ (when-let* ((children (cl--class-children (cl--find-class name))))
(error "Type has children: %S" children))
- (cl-remprop name 'cl--type-error)
+ (cl-remprop name 'cl--type-flag)
(cl-remprop name 'cl--class)
(cl-remprop name 'cl-deftype-handler)
+ (setq cl--type-dispatch-list (delq name cl--type-dispatch-list))
(setq cl--type-list (delq name cl--type-list)))
(defun cl--type-deftype (name parents &optional docstring)
;; FIXME: Should we also receive the arglist?
- "Generalize cl-type with NAME for method dispatching.
+ "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 ((typelist cl--type-list)
- (oldplist (copy-sequence (symbol-plist name))))
- (condition-case err
- (let* ((class (cl--find-class name))
- (recorded (memq name typelist)))
- (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)
- ;; 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))
- (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 typelist))
- ;; `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.
- ;; FIXME: This global operation is a bit worrisome, because it
- ;; scales poorly with the number of types. I guess it's OK
- ;; for now because `cl-deftype' is not very popular, but it'll
- ;; probably need to be replaced at some point. Maybe we
- ;; should simply require that the parents be defined already,
- ;; then we can just `push' the new type, knowing it's in
- ;; topological order by construction.
- (setq cl--type-list
- (merge-ordered-lists
- (cl--type-dag typelist)
- (lambda (_) (error "Invalid dependency graph")))))
- (error
- (setf (symbol-plist name) oldplist)
- (error (format "Define %S failed: %s"
- name (error-message-string err)))))))
+ (condition-case err
+ (let* ((class (cl--find-class name))
+ (recorded (memq name cl--type-list)))
+ (if (null class)
+ (or (null recorded)
+ (error "Type registered, but doesn't exist"))
+ (or recorded (error "Type exists, but not registered"))
+ (or (cl-type-class-p class)
+ ;; FIXME: We have some uses `cl-deftype' in Emacs that
+ ;; "complement" another declaration of the same type,
+ ;; so maybe we should turn this into a warning (and
+ ;; not overwrite the `cl--find-class' in that case)?
+ (error "Type in another class: %S" (type-of class))))
+ ;; Setup a type descriptor for NAME.
+ (setf (cl--find-class name)
+ (cl--type-class-make name docstring parents))
+ ;; Reset NAME as a newly defined type.
+ (cl-remprop name 'cl--type-flag)
+ ;; Record new type. The constructor of the class
+ ;; `cl-type-class' already ensures that parent types must be
+ ;; defined before their "child" types (i.e. already added to
+ ;; the `cl--type-list' for types defined with `cl-deftype').
+ ;; So it is enough to simply push a new type at the beginning
+ ;; of the list.
+ ;; Redefinition is more complicated, because child types may
+ ;; be in the list, so moving the type to the head can be
+ ;; incorrect. The "cheap" solution is to leave the list
+ ;; unchanged (and hope the redefinition doesn't change the
+ ;; hierarchy too much).
+ ;; Side note: Redefinitions introduce other problems as well
+ ;; because the class object's `parents` slot contains
+ ;; references to `cl--class` objects, so after a redefinition
+ ;; via (setf (cl--find-class FOO) ...), the children's
+ ;; `parents` slots point to the old class object. That's a
+ ;; problem that affects all types and that we don't really try
+ ;; to solve currently.
+ (or recorded (push name cl--type-list)))
+ (error
+ (error (format "Define %S failed: %s"
+ name (error-message-string err))))))
;;;###autoload
(defmacro cl-deftype2 (name arglist &rest body)
(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)))
+ ;; Mark TYPE as in-error and remove it from the dispatch list.
+ (put type 'cl--type-flag 'error)
+ (setq cl--type-dispatch-list (delq type cl--type-dispatch-list))
(warn "cl-types-of %s, %s" type (error-message-string error)))
nil)
;; to find which cl-types may need to be checked.
;;
(defun cl-types-of (object)
- "Return the types OBJECT belongs to.
+"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)
- ;; Build a list of all types OBJECT belongs to.
- (dolist (type cl--type-list)
+(let* ((root-type (cl-type-of object))
+ (found (list root-type)))
+ ;; Build a list of all types OBJECT belongs to.
+ (dolist (type cl--type-list)
+ (let ((flag (get type 'cl--type-flag)))
(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))
+ (not (eq flag 'error))
+ ;; Skip type which we are sure will not match.
+ (or (null flag) (eq flag root-type))
;; If OBJECT is of type, add type to the matching list.
(condition-case-unless-debug e
(cl-typep object type)
(error (cl--type-error type e)))
- (push type found)))
- ;; Return an unique value of the list of types OBJECT belongs to,
- ;; which is also the list of specifiers for OBJECT.
- (with-memoization (gethash found cl--type-unique)
- ;; Compute a DAG from the collected matching types.
- (let (dag)
- (dolist (type found)
- (let ((pl (cl--type-parents type)))
- (while pl
- (push pl dag)
- (setq pl (cdr pl)))))
- ;; Compute an ordered list of types from the DAG.
- (merge-ordered-lists
- (nreverse (cons (cl--type-parents (cl-type-of object))
- dag)))))))
+ (or flag (put type 'cl--type-flag root-type))
+ (push type found))))
+ ;; Return an unique value of the list of types OBJECT belongs to,
+ ;; which is also the list of specifiers for OBJECT.
+ (with-memoization (gethash found cl--type-unique)
+ ;; Compute an ordered list of types from the DAG.
+ (merge-ordered-lists (mapcar #'cl--type-parents found)))))
;;; Method dispatching
;;
+
+;; For a declaration like
+;;
+;; (cl-deftype list-of (elem-type)
+;; `(and list
+;; (satisfies ,(lambda (list)
+;; (cl-every (lambda (elem)
+;; (cl-typep elem elem-type))
+;; list)))))
+;;
+;; we add the type to `cl--type-list' even though it's unusable there
+;; (the `cl-typep` call in `cl-types-of' will always signal an error
+;; because the type can't be used without argument).
+;;
+;; One way to solve this (and even open up the possibility to
+;; dispatch on complex types like `(list-of FOO)') is to populate
+;; `cl--type-dispatch-list' (i.e. the list of types that need to
+;; be checked during dispatch) from `cl-generic-generalizers' so it
+;; includes only those types for which there's a method, rather than
+;; all defined types.
+
(cl-generic-define-generalizer cl--type-generalizer
20 ;; "typeof" < "cl-types-of" < "head" priority
- (lambda (obj &rest _) `(cl-types-of ,obj))
+ (lambda (obj &rest _) `(let ((cl--type-list cl--type-dispatch-list))
+ (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 cl-types."
(if (cl--type-p type)
- (list cl--type-generalizer)
+ (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.
+ (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)))
(provide 'cl-types)
projects / emacs.git / commitdiff