X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-type.lisp;h=e7b96f8d930039c4793ffa026cda8ac49318e29c;hb=7a0f4c68d94ff6c9a54c7605b6fd3cd8125c1c8c;hp=31f05ae0d159e06baf7ec0eccbe1c5bb2319cb46;hpb=9dfd024c6fe1337ae7b76f0fd68b8f3208a6c987;p=sbcl.git diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 31f05ae..e7b96f8 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -221,10 +221,15 @@ ;; specifier to win. (type (missing-arg) :type ctype)) -;;; The NAMED-TYPE is used to represent *, T and NIL. These types must -;;; be super- or sub-types of all types, not just classes and * and -;;; NIL aren't classes anyway, so it wouldn't make much sense to make -;;; them built-in classes. +;;; The NAMED-TYPE is used to represent *, T and NIL, the standard +;;; special cases, as well as other special cases needed to +;;; interpolate between regions of the type hierarchy, such as +;;; INSTANCE (which corresponds to all those classes with slots which +;;; are not funcallable), FUNCALLABLE-INSTANCE (those classes with +;;; slots which are funcallable) and EXTENDED-SEQUUENCE (non-LIST +;;; non-VECTOR classes which are also sequences). These special cases +;;; are the ones that aren't really discussed by Baker in his +;;; "Decision Procedure for SUBTYPEP" paper. (defstruct (named-type (:include ctype (class-info (type-class-or-lose 'named))) (:copier nil)) @@ -387,41 +392,78 @@ (class-info (type-class-or-lose 'member)) (enumerable t)) (:copier nil) - (:constructor %make-member-type (members)) + (:constructor %make-member-type (xset fp-zeroes)) #-sb-xc-host (:pure nil)) - ;; the things in the set, with no duplications - (members nil :type list)) -(defun make-member-type (&key members) - (declare (type list members)) - ;; make sure that we've removed duplicates - (aver (= (length members) (length (remove-duplicates members)))) + (xset (missing-arg) :type xset) + (fp-zeroes (missing-arg) :type list)) +(defun make-member-type (&key xset fp-zeroes members) + (unless xset + (aver (not fp-zeroes)) + (setf xset (alloc-xset)) + (dolist (elt members) + (if (fp-zero-p elt) + (pushnew elt fp-zeroes) + (add-to-xset elt xset)))) ;; if we have a pair of zeros (e.g. 0.0d0 and -0.0d0), then we can ;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric ;; ranges are compared by arithmetic operators (while MEMBERship is ;; compared by EQL). -- CSR, 2003-04-23 - (let ((singlep (subsetp `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0) members)) - (doublep (subsetp `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0) members)) - #!+long-float - (longp (subsetp `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0) members))) - (if (or singlep doublep #!+long-float longp) - (let (union-types) - (when singlep - (push (ctype-of 0.0f0) union-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :single-float-negative-zero)) 0.0f0)))) - (when doublep - (push (ctype-of 0.0d0) union-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :double-float-negative-zero)) 0.0d0)))) + (let ((unpaired nil) + (union-types nil)) + (do ((tail (cdr fp-zeroes) (cdr tail)) + (zero (car fp-zeroes) (car tail))) + ((not zero)) + (macrolet ((frob (c) + `(let ((neg (neg-fp-zero zero))) + (if (member neg tail) + (push (ctype-of ,c) union-types) + (push zero unpaired))))) + (etypecase zero + (single-float (frob 0.0f0)) + (double-float (frob 0.0d0)) #!+long-float - (when longp - (push (ctype-of 0.0l0) union-types) - (setf members (set-difference members `(,(load-time-value (make-unportable-float :long-float-negative-zero)) 0.0l0)))) - (aver (not (null union-types))) - (make-union-type t - (if (null members) - union-types - (cons (%make-member-type members) - union-types)))) - (%make-member-type members)))) + (long-float (frob 0.0l0))))) + ;; The actual member-type contains the XSET (with no FP zeroes), + ;; and a list of unpaired zeroes. + (let ((member-type (unless (and (xset-empty-p xset) (not unpaired)) + (%make-member-type xset unpaired)))) + (cond (union-types + (make-union-type t (if member-type + (cons member-type union-types) + union-types))) + (member-type + member-type) + (t + *empty-type*))))) + +(defun member-type-size (type) + (+ (length (member-type-fp-zeroes type)) + (xset-count (member-type-xset type)))) + +(defun member-type-member-p (x type) + (if (fp-zero-p x) + (and (member x (member-type-fp-zeroes type)) t) + (xset-member-p x (member-type-xset type)))) + +(defun mapcar-member-type-members (function type) + (declare (function function)) + (collect ((results)) + (map-xset (lambda (x) + (results (funcall function x))) + (member-type-xset type)) + (dolist (zero (member-type-fp-zeroes type)) + (results (funcall function zero))) + (results))) + +(defun mapc-member-type-members (function type) + (declare (function function)) + (map-xset function (member-type-xset type)) + (dolist (zero (member-type-fp-zeroes type)) + (funcall function zero))) + +(defun member-type-members (type) + (append (member-type-fp-zeroes type) + (xset-members (member-type-xset type)))) ;;; A COMPOUND-TYPE is a type defined out of a set of types, the ;;; common parent of UNION-TYPE and INTERSECTION-TYPE. @@ -530,11 +572,6 @@ ((eq (info :type :kind spec) :instance) (find-classoid spec)) ((typep spec 'classoid) - ;; There doesn't seem to be any way to translate - ;; (TYPEP SPEC 'BUILT-IN-CLASS) into something which can be - ;; executed on the host Common Lisp at cross-compilation time. - #+sb-xc-host (error - "stub: (TYPEP SPEC 'BUILT-IN-CLASS) on xc host") (if (typep spec 'built-in-classoid) (or (built-in-classoid-translation spec) spec) spec))