1.0.10.51: New function: THREAD-YIELD

[sbcl.git] / src / code / early-type.lisp

diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index b1833ec..0aa0974 100644 (file)
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -221,10 +221,15 @@
   ;; specifier to win.
   (type (missing-arg) :type ctype))
 
   ;; 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))
 (defstruct (named-type (:include ctype
                                  (class-info (type-class-or-lose 'named)))
                        (:copier nil))

@@ -341,9 +346,9 @@
   ;              (sort (mapcar #'car pairs) #'<)))
   ;; aver that the cars of the list elements are sorted into increasing order
   (aver (or (null pairs)
   ;              (sort (mapcar #'car pairs) #'<)))
   ;; aver that the cars of the list elements are sorted into increasing order
   (aver (or (null pairs)

-           (do ((p pairs (cdr p)))
-               ((null (cdr p)) t)
-             (when (> (caar p) (caadr p)) (return nil)))))
+            (do ((p pairs (cdr p)))
+                ((null (cdr p)) t)
+              (when (> (caar p) (caadr p)) (return nil)))))

   (let ((pairs (let (result)
                 (do ((pairs pairs (cdr pairs)))
                     ((null pairs) (nreverse result))
   (let ((pairs (let (result)
                 (do ((pairs pairs (cdr pairs)))
                     ((null pairs) (nreverse result))

@@ -393,35 +398,62 @@
   (members nil :type list))
 (defun make-member-type (&key members)
   (declare (type list members))
   (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))))

   ;; 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
   ;; 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))
+  (let ((n-single (load-time-value
+                   (make-unportable-float :single-float-negative-zero)))
+        (n-double (load-time-value
+                   (make-unportable-float :double-float-negative-zero)))

         #!+long-float
         #!+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))))
-          #!+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))))
+        (n-long (load-time-value
+                 (make-unportable-float :long-float-negative-zero)))
+        (singles nil)
+        (doubles nil)
+        #!+long-float
+        (longs nil))
+    ;; Just a single traversal, please! MEMBERS2 starts as with MEMBERS,
+    ;; sans any zeroes -- if there are any paired zeroes then the
+    ;; unpaired ones are added back to it.
+    (let (members2)
+      (dolist (elt members)
+        (if (and (numberp elt) (zerop elt))
+            (typecase elt
+              (single-float (push elt singles))
+              (double-float (push elt doubles))
+              #!+long-float
+              (long-float   (push elt longs)))
+            (push elt members2)))
+      (let ((singlep (and (member 0.0f0 singles)
+                          (member n-single singles)
+                          (or (aver (= 2 (length singles))) t)))
+            (doublep (and (member 0.0d0 doubles)
+                          (member n-double doubles)
+                          (or (aver (= 2 (length doubles))) t)))
+            #!+long-float
+            (longp (and (member 0.0l0 longs)
+                        (member n-long longs)
+                        (or (aver (= 2 (lenght longs))) t))))
+        (if (or singlep doublep #!+long-float longp)
+            (let (union-types)
+              (if singlep
+                  (push (ctype-of 0.0f0) union-types)
+                  (setf members2 (nconc singles members2)))
+              (if doublep
+                  (push (ctype-of 0.0d0) union-types)
+                  (setf members2 (nconc doubles members2)))
+              #!+long-float
+              (if longp
+                  (push (ctype-of 0.0l0) union-types)
+                  (setf members2 (nconc longs members2)))
+              (aver (not (null union-types)))
+              (make-union-type t
+                               (if (null members2)
+                                   union-types
+                                   (cons (%make-member-type members2)
+                                         union-types))))
+            (%make-member-type members))))))

 
 ;;; A COMPOUND-TYPE is a type defined out of a set of types, the
 ;;; common parent of UNION-TYPE and INTERSECTION-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 +562,6 @@
            ((eq (info :type :kind spec) :instance)
             (find-classoid spec))
            ((typep spec 'classoid)
            ((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))
             (if (typep spec 'built-in-classoid)
                 (or (built-in-classoid-translation spec) spec)
                 spec))