X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-type.lisp;h=43394ffa6d9e5a571897202d0ef1736a4745aab2;hb=50f728671defadb8f7b1e8691c984cb0e6aba17c;hp=4bb7c97d61cf53d3221cc9ffbef12589c94bf237;hpb=814fc23f60ba84318a3dfea112e6d98fd0293835;p=sbcl.git

diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index 4bb7c97..43394ff 100644
--- 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)))
 
 ;;;; type utilities
 
@@ -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