diff options
Diffstat (limited to 'lisp/emacs-lisp/comp-cstr.el')
| -rw-r--r-- | lisp/emacs-lisp/comp-cstr.el | 240 |
1 files changed, 189 insertions, 51 deletions
diff --git a/lisp/emacs-lisp/comp-cstr.el b/lisp/emacs-lisp/comp-cstr.el index 4653e1f991c..339a6142178 100644 --- a/lisp/emacs-lisp/comp-cstr.el +++ b/lisp/emacs-lisp/comp-cstr.el @@ -36,6 +36,7 @@ ;;; Code: (require 'cl-lib) +(require 'cl-extra) ;HACK: For `cl-find-class' when `cl-loaddefs' is missing. (defconst comp--typeof-builtin-types (mapcar (lambda (x) (append x '(t))) @@ -86,7 +87,43 @@ 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." + `(,@(cl--class-allparents (cl--struct-get-class x)) + ;; FIXME: AFAICT, `comp--all-classes' will also find those struct types + ;; which use :type and can thus be either `vector' or `cons' (the latter + ;; isn't `atom'). + 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 +144,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)) @@ -218,69 +264,130 @@ Return them as multiple value." ;;; Type handling. -(defun comp-normalize-typeset (typeset) - "Sort TYPESET and return it." - (cl-sort (cl-remove-duplicates typeset) - (lambda (x y) - (string-lessp (symbol-name x) - (symbol-name y))))) +(defun comp--sym-lessp (x y) + "Like `string-lessp' but for symbol names." + (string-lessp (symbol-name x) + (symbol-name y))) -(defun comp-supertypes (type) - "Return a list of pairs (supertype . hierarchy-level) for TYPE." - (cl-loop - named outer - with found = nil - for l in comp--typeof-builtin-types - do (cl-loop - for x in l - for i from (length l) downto 0 - when (eq type x) - do (setf found t) - when found - collect `(,x . ,i) into res - finally (when found - (cl-return-from outer res))))) - -(defun comp-common-supertype-2 (type1 type2) - "Return the first common supertype of TYPE1 TYPE2." - (when-let ((types (cl-intersection - (comp-supertypes type1) - (comp-supertypes type2) - :key #'car))) - (car (cl-reduce (lambda (x y) - (if (> (cdr x) (cdr y)) x y)) - types)))) - -(defun comp-common-supertype (&rest types) - "Return the first common supertype of TYPES." - (or (gethash types (comp-cstr-ctxt-common-supertype-mem comp-ctxt)) - (puthash types - (cl-reduce #'comp-common-supertype-2 types) - (comp-cstr-ctxt-common-supertype-mem comp-ctxt)))) +(defun comp--direct-supertypes (type) + "Return the direct supertypes of TYPE." + (let ((supers (comp-supertypes type))) + (cl-assert (eq type (car supers))) + (cl-loop + with notdirect = nil + with direct = nil + for parent in (cdr supers) + unless (memq parent notdirect) + do (progn + (push parent direct) + (setq notdirect (append notdirect (comp-supertypes parent)))) + finally return direct))) (defsubst comp-subtype-p (type1 type2) "Return t if TYPE1 is a subtype of TYPE2 or nil otherwise." (let ((types (cons type1 type2))) (or (gethash types (comp-cstr-ctxt-subtype-p-mem comp-ctxt)) (puthash types - (eq (comp-common-supertype-2 type1 type2) type2) + (memq type2 (comp-supertypes type1)) (comp-cstr-ctxt-subtype-p-mem comp-ctxt))))) +(defun comp--normalize-typeset0 (typeset) + ;; For every type search its supertypes. If all the subtypes of a + ;; supertype are presents remove all of them, add the identified + ;; supertype and restart. + ;; FIXME: The intention is to return a 100% equivalent but simpler + ;; typeset, but this is only the case when the supertype is abstract + ;; and "final/closed" (i.e. can't have new subtypes). + (when typeset + (while (eq 'restart + (cl-loop + named main + for sup in (cl-remove-duplicates + (apply #'append + (mapcar #'comp--direct-supertypes typeset))) + for subs = (comp--direct-subtypes sup) + when (and (length> subs 1) ;;FIXME: Why? + ;; Every subtype of `sup` is a subtype of + ;; some element of `typeset`? + ;; It's tempting to just check (member x typeset), + ;; but think of the typeset (marker number), + ;; where `sup' is `integer-or-marker' and `sub' + ;; is `integer'. + (cl-every (lambda (sub) + (cl-some (lambda (type) + (comp-subtype-p sub type)) + typeset)) + subs)) + do (progn + (setq typeset (cons sup (cl-set-difference typeset subs))) + (cl-return-from main 'restart))))) + typeset)) + +(defun comp-normalize-typeset (typeset) + "Sort TYPESET and return it." + (cl-sort (comp--normalize-typeset0 (cl-remove-duplicates typeset)) #'comp--sym-lessp)) + +(defun comp--direct-subtypes (type) + "Return all the direct subtypes of TYPE." + ;; TODO: memoize. + (let ((subtypes ())) + (dolist (j (comp-cstr-ctxt-typeof-types comp-ctxt)) + (let ((occur (memq type j))) + (when occur + (while (not (eq j occur)) + (let ((candidate (pop j))) + (when (and (not (memq candidate subtypes)) + (memq type (comp--direct-supertypes candidate))) + (push candidate subtypes))))))) + (cl-sort subtypes #'comp--sym-lessp))) + +(defun comp--intersection (list1 list2) + "Like `cl-intersection` but preserves the order of one of its args." + (if (equal list1 list2) list1 + (let ((res nil)) + (while list2 + (if (memq (car list2) list1) + (push (car list2) res)) + (pop list2)) + (nreverse res)))) + +(defun comp-supertypes (type) + "Return the ordered list of supertypes of TYPE." + ;; FIXME: We should probably keep the results in + ;; `comp-cstr-ctxt-typeof-types' (or maybe even precompute them + ;; and maybe turn `comp-cstr-ctxt-typeof-types' into a hash-table). + ;; Or maybe we shouldn't keep structs and defclasses in it, + ;; and just use `cl--class-allparents' when needed (and refuse to + ;; compute their direct subtypes since we can't know them). + (cl-loop + named loop + with above + for lane in (comp-cstr-ctxt-typeof-types comp-ctxt) + do (let ((x (memq type lane))) + (cond + ((null x) nil) + ((eq x lane) (cl-return-from loop x)) ;A base type: easy case. + (t (setq above + (if above (comp--intersection x above) x))))) + finally return above)) + (defun comp-union-typesets (&rest typesets) "Union types present into TYPESETS." (or (gethash typesets (comp-cstr-ctxt-union-typesets-mem comp-ctxt)) (puthash typesets (cl-loop - with types = (apply #'append typesets) + ;; List of (TYPE . SUPERTYPES)", ordered from + ;; "most general" to "least general" + with typess = (sort (mapcar #'comp-supertypes + (apply #'append typesets)) + (lambda (l1 l2) + (<= (length l1) (length l2)))) with res = '() - for lane in comp--typeof-builtin-types - do (cl-loop - with last = nil - for x in lane - when (memq x types) - do (setf last x) - finally (when last - (push last res))) + for types in typess + ;; Don't keep this type if it's a subtype of one of + ;; the other types. + unless (comp--intersection types res) + do (push (car types) res) finally return (comp-normalize-typeset res)) (comp-cstr-ctxt-union-typesets-mem comp-ctxt)))) @@ -774,7 +881,7 @@ Non memoized version of `comp-cstr-intersection-no-mem'." (comp-subtype-p neg-type pos-type)) do (cl-loop with found - for (type . _) in (comp-supertypes neg-type) + for type in (comp-supertypes neg-type) when found collect type into res when (eq type pos-type) @@ -867,6 +974,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 @@ -1121,8 +1245,8 @@ FN non-nil indicates we are parsing a function lambda list." :ret (comp-type-spec-to-cstr ret))) (_ (error "Invalid type specifier")))) -(defun comp-cstr-to-type-spec (cstr) - "Given CSTR return its type specifier." +(defun comp--simple-cstr-to-type-spec (cstr) + "Given a non comp-cstr-f CSTR return its type specifier." (let ((valset (comp-cstr-valset cstr)) (typeset (comp-cstr-typeset cstr)) (range (comp-cstr-range cstr)) @@ -1176,6 +1300,20 @@ FN non-nil indicates we are parsing a function lambda list." `(not ,final) final)))) +(defun comp-cstr-to-type-spec (cstr) + "Given CSTR return its type specifier." + (cl-etypecase cstr + (comp-cstr-f + `(function + ,(mapcar (lambda (x) + (cl-etypecase x + (comp-cstr (comp-cstr-to-type-spec x)) + (symbol x))) + (comp-cstr-f-args cstr)) + ,(comp--simple-cstr-to-type-spec (comp-cstr-f-ret cstr)))) + (comp-cstr + (comp--simple-cstr-to-type-spec cstr)))) + (provide 'comp-cstr) ;;; comp-cstr.el ends here |