diff options
Diffstat (limited to 'lisp/emacs-lisp/comp-cstr.el')
| -rw-r--r-- | lisp/emacs-lisp/comp-cstr.el | 64 |
1 files changed, 62 insertions, 2 deletions
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index d4200c16c19..416ca7f11b0 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -86,7 +86,41 @@ Integer values are handled in the `range' slot.") (ret nil :type (or comp-cstr comp-cstr-f) :documentation "Returned value.")) +(defun comp--cl-class-hierarchy (x) + "Given a class name `x' return its hierarchy." + `(,@(mapcar #'cl--struct-class-name (cl--struct-all-parents + (cl--struct-get-class x))) + atom + t)) + +(defun comp--all-classes () + "Return all non built-in type names currently defined." + (let (res) + (mapatoms (lambda (x) + (when (cl-find-class x) + (push x res))) + obarray) + res)) + +(defun comp--compute-typeof-types () + (append comp--typeof-builtin-types + (mapcar #'comp--cl-class-hierarchy (comp--all-classes)))) + +(defun comp--compute--pred-type-h () + (cl-loop with h = (make-hash-table :test #'eq) + for class-name in (comp--all-classes) + for pred = (get class-name 'cl-deftype-satisfies) + when pred + do (puthash pred class-name h) + finally return h)) + (cl-defstruct comp-cstr-ctxt + (typeof-types (comp--compute-typeof-types) + :type list + :documentation "Type hierarchy.") + (pred-type-h (comp--compute--pred-type-h) + :type hash-table + :documentation "Hash pred -> type.") (union-typesets-mem (make-hash-table :test #'equal) :type hash-table :documentation "Serve memoization for `comp-union-typesets'.") @@ -107,6 +141,15 @@ Integer values are handled in the `range' slot.") :documentation "Serve memoization for `intersection-mem'.")) +(defun comp-cstr-ctxt-update-type-slots (ctxt) + "Update the type related slots of CTXT. +This must run after byte compilation in order to account for user +defined types." + (setf (comp-cstr-ctxt-typeof-types ctxt) + (comp--compute-typeof-types)) + (setf (comp-cstr-ctxt-pred-type-h ctxt) + (comp--compute--pred-type-h))) + (defmacro with-comp-cstr-accessors (&rest body) "Define some quick accessor to reduce code vergosity in BODY." (declare (debug (form body)) @@ -230,7 +273,7 @@ Return them as multiple value." (cl-loop named outer with found = nil - for l in comp--typeof-builtin-types + for l in (comp-cstr-ctxt-typeof-types comp-ctxt) do (cl-loop for x in l for i from (length l) downto 0 @@ -273,7 +316,7 @@ Return them as multiple value." (cl-loop with types = (apply #'append typesets) with res = '() - for lane in comp--typeof-builtin-types + for lane in (comp-cstr-ctxt-typeof-types comp-ctxt) do (cl-loop with last = nil for x in lane @@ -867,6 +910,23 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (null (neg cstr)) (equal (typeset cstr) '(cons))))) +;; Move to comp.el? +(defsubst comp-cstr-cl-tag-p (cstr) + "Return non-nil if CSTR is a CL tag." + (with-comp-cstr-accessors + (and (null (range cstr)) + (null (neg cstr)) + (null (typeset cstr)) + (length= (valset cstr) 1) + (string-match (rx "cl-struct-" (group-n 1 (1+ not-newline)) "-tags") + (symbol-name (car (valset cstr))))))) + +(defsubst comp-cstr-cl-tag (cstr) + "If CSTR is a CL tag return its tag name." + (with-comp-cstr-accessors + (and (comp-cstr-cl-tag-p cstr) + (intern (match-string 1 (symbol-name (car (valset cstr)))))))) + (defun comp-cstr-= (dst op1 op2) "Constraint OP1 being = OP2 setting the result into DST." (with-comp-cstr-accessors |