1.0.30.41: Octets support for ebcdic-us

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

diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index b338ad7..4ad4966 100644 (file)
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -63,7 +63,7 @@
   ;; true if other &KEY arguments are allowed
   (allowp nil :type boolean))
 
   ;; true if other &KEY arguments are allowed
   (allowp nil :type boolean))
 

-(defun canonicalize-args-type-args (required optional rest)
+(defun canonicalize-args-type-args (required optional rest &optional keyp)

   (when (eq rest *empty-type*)
     ;; or vice-versa?
     (setq rest nil))
   (when (eq rest *empty-type*)
     ;; or vice-versa?
     (setq rest nil))

@@ -72,19 +72,20 @@
         for opt in optional
         do (cond ((eq opt *empty-type*)
                   (return (values required (subseq optional i) rest)))
         for opt in optional
         do (cond ((eq opt *empty-type*)
                   (return (values required (subseq optional i) rest)))

-                 ((neq opt rest)
+                 ((and (not keyp) (neq opt rest))

                   (setq last-not-rest i)))
         finally (return (values required
                   (setq last-not-rest i)))
         finally (return (values required

-                                (if last-not-rest
-                                    (subseq optional 0 (1+ last-not-rest))
-                                    nil)
+                                (cond (keyp
+                                       optional)
+                                      (last-not-rest
+                                       (subseq optional 0 (1+ last-not-rest))))

                                 rest))))
 
 (defun args-types (lambda-list-like-thing)
   (multiple-value-bind
         (required optional restp rest keyp keys allowp auxp aux
                   morep more-context more-count llk-p)
                                 rest))))
 
 (defun args-types (lambda-list-like-thing)
   (multiple-value-bind
         (required optional restp rest keyp keys allowp auxp aux
                   morep more-context more-count llk-p)

-      (parse-lambda-list-like-thing lambda-list-like-thing)
+      (parse-lambda-list-like-thing lambda-list-like-thing :silent t)

     (declare (ignore aux morep more-context more-count))
     (when auxp
       (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list-like-thing))
     (declare (ignore aux morep more-context more-count))
     (when auxp
       (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list-like-thing))

@@ -106,7 +107,7 @@
                    :type (single-value-specifier-type (second key))))))
              (key-info))))
       (multiple-value-bind (required optional rest)
                    :type (single-value-specifier-type (second key))))))
              (key-info))))
       (multiple-value-bind (required optional rest)

-          (canonicalize-args-type-args required optional rest)
+          (canonicalize-args-type-args required optional rest keyp)

         (values required optional rest keyp keywords allowp llk-p)))))
 
 (defstruct (values-type
         (values required optional rest keyp keywords allowp llk-p)))))
 
 (defstruct (values-type

@@ -221,10 +222,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))

@@ -337,8 +343,13 @@
             (:copier nil))
   (pairs (missing-arg) :type list :read-only t))
 (defun make-character-set-type (&key pairs)
             (:copier nil))
   (pairs (missing-arg) :type list :read-only t))
 (defun make-character-set-type (&key pairs)

-  (aver (equal (mapcar #'car pairs)
-              (sort (mapcar #'car pairs) #'<)))
+  ; (aver (equal (mapcar #'car 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)))))

   (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))

@@ -382,41 +393,78 @@
                                   (class-info (type-class-or-lose 'member))
                                   (enumerable t))
                         (:copier nil)
                                   (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))
                         #-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
   ;; 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
           #!+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.
 
 ;;; A COMPOUND-TYPE is a type defined out of a set of types, the
 ;;; common parent of UNION-TYPE and INTERSECTION-TYPE.

@@ -525,11 +573,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))