0.7.13.pcl-class.9

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

diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index e4df2ee..43394ff 100644 (file)
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -38,6 +38,18 @@
 (defstruct (unknown-type (:include hairy-type)
                         (:copier nil)))
 
+(defstruct (negation-type (:include ctype
+                                   (class-info (type-class-or-lose 'negation))
+                                   ;; FIXME: is this right?  It's
+                                   ;; what they had before, anyway
+                                   (enumerable t)
+                                   (might-contain-other-types-p t))
+                         (:copier nil)
+                         #!+cmu (:pure nil))
+  (type (missing-arg) :type ctype))
+
+(!define-type-class negation)
+
 ;;; ARGS-TYPE objects are used both to represent VALUES types and
 ;;; to represent FUNCTION types.
 (defstruct (args-type (:include ctype)
@@ -183,6 +195,11 @@
            (t 
             ;; no canonicalization necessary
             (values low high)))
+       (when (and (eq class 'rational)
+                  (integerp canonical-low)
+                  (integerp canonical-high)
+                  (= canonical-low canonical-high))
+         (setf class 'integer))
        (%make-numeric-type :class class
                            :format format
                            :complexp complexp
@@ -290,17 +307,22 @@
                       ;; possibly elsewhere, we slam all CONS-TYPE
                       ;; objects into canonical form w.r.t. this
                       ;; equivalence at creation time.
-                      make-cons-type (car-raw-type
-                                      cdr-raw-type
-                                      &aux
-                                      (car-type (type-*-to-t car-raw-type))
-                                      (cdr-type (type-*-to-t cdr-raw-type))))
+                      %make-cons-type (car-raw-type
+                                       cdr-raw-type
+                                       &aux
+                                       (car-type (type-*-to-t car-raw-type))
+                                       (cdr-type (type-*-to-t cdr-raw-type))))
                      (:copier nil))
   ;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types)
   ;;
   ;; FIXME: Most or all other type structure slots could also be :READ-ONLY.
   (car-type (missing-arg) :type ctype :read-only t)
   (cdr-type (missing-arg) :type ctype :read-only t))
+(defun make-cons-type (car-type cdr-type)
+  (if (or (eq car-type *empty-type*)
+         (eq cdr-type *empty-type*))
+      *empty-type*
+      (%make-cons-type car-type cdr-type)))
 \f
 ;;;; type utilities
 
@@ -314,7 +336,7 @@
                                 (logand (sxhash x) #x3FF))
               :hash-bits 10
               :init-wrapper !cold-init-forms)
-             ((orig equal))
+             ((orig equal-but-no-car-recursion))
   (let ((u (uncross orig)))
     (or (info :type :builtin u)
        (let ((spec (type-expand u)))
@@ -322,15 +344,15 @@
           ((and (not (eq spec u))
                 (info :type :builtin spec)))
           ((eq (info :type :kind spec) :instance)
-           (sb!xc:find-class spec))
-          ((typep spec 'class)
+           (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-class)
-               (or (built-in-class-translation spec) spec)
+           (if (typep spec 'built-in-classoid)
+               (or (built-in-classoid-translation spec) spec)
                spec))
           (t
            (let* (;; FIXME: This automatic promotion of FOO-style
@@ -364,6 +386,12 @@
       (error "VALUES type illegal in this context:~%  ~S" x))
     res))
 
+(defun single-value-specifier-type (x)
+  (let ((res (specifier-type x)))
+    (if (eq res *wild-type*)
+        *universal-type*
+        res)))
+
 ;;; Similar to MACROEXPAND, but expands DEFTYPEs. We don't bother
 ;;; returning a second value.
 (defun type-expand (form)