X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftypedefs.lisp;h=45b91042c9ca054105f306d68cf5955089b0cd8a;hb=f1407e424f1063203af07d2e61ceef58515a4797;hp=bcbfecea2be2161a06f4a08d6c116eece6e23be0;hpb=2c6b90e36a7c0377cd79625eb6c94d580f98cb93;p=sbcl.git diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index bcbfece..45b9104 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -69,16 +69,26 @@ ;; named TYPE-CLASS-INFO which is an accessor for the CTYPE structure ;; even though the TYPE-CLASS structure also exists in the system. ;; Rename this slot: TYPE-CLASS or ASSOCIATED-TYPE-CLASS or something. - (class-info (required-argument) :type type-class) + (class-info (missing-arg) :type type-class) ;; True if this type has a fixed number of members, and as such ;; could possibly be completely specified in a MEMBER type. This is ;; used by the MEMBER type methods. (enumerable nil :read-only t) ;; an arbitrary hash code used in EQ-style hashing of identity ;; (since EQ hashing can't be done portably) - (hash-value (random (1+ most-positive-fixnum)) + (hash-value (random #.(ash 1 20)) :type (and fixnum unsigned-byte) - :read-only t)) + :read-only t) + ;; Can this object contain other types? A global property of our + ;; implementation (which unfortunately seems impossible to enforce + ;; with assertions or other in-the-code checks and constraints) is + ;; that subclasses which don't contain other types correspond to + ;; disjoint subsets (except of course for the NAMED-TYPE T, which + ;; covers everything). So NUMBER-TYPE is disjoint from CONS-TYPE is + ;; is disjoint from MEMBER-TYPE and so forth. But types which can + ;; contain other types, like HAIRY-TYPE and INTERSECTION-TYPE, can + ;; violate this rule. + (might-contain-other-types-p nil :read-only t)) (def!method print-object ((ctype ctype) stream) (print-unreadable-object (ctype stream :type t) (prin1 (type-specifier ctype) stream))) @@ -118,6 +128,15 @@ (logand (logxor (ash (type-hash-value type1) -3) (type-hash-value type2)) #xFF)) +#!-sb-fluid (declaim (inline type-list-cache-hash)) +(declaim (ftype (function (list) (unsigned-byte 8)) type-list-cache-hash)) +(defun type-list-cache-hash (types) + (logand (loop with res = 0 + for type in types + for hash = (type-hash-value type) + do (setq res (logxor res hash)) + finally (return res)) + #xFF)) ;;;; cold loading initializations