Index: src/code/latetype.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/latetype.lisp,v
retrieving revision 1.96
diff u r1.96 latetype.lisp
 src/code/latetype.lisp 26 Aug 2003 08:58:31 0000 1.96
+++ src/code/latetype.lisp 26 Aug 2003 12:10:20 0000
@@ 927,65 +927,27 @@
;;;; These are fully general operations on CTYPEs: they'll always
;;;; return a CTYPE representing the result.
;;; shared logic for unions and intersections: Return a vector of
+;;; shared logic for unions and intersections: Return a list of
;;; types representing the same types as INPUTTYPES, but with
;;; COMPOUNDTYPEs satisfying %COMPOUNDTYPEP broken up into their
;;; component types, and with any SIMPLY2 simplifications applied.
(declaim (inline simplifiedcompoundtypes))
(defun simplifiedcompoundtypes (inputtypes %compoundtypep simplify2)
 (declare (function %compoundtypep simplify2))
 (let ((types (makearray (length inputtypes)
 :fillpointer 0
 :adjustable t
 :elementtype 'ctype)))
 (labels ((accumulatecompoundtype (type)
 (if (funcall %compoundtypep type)
 (dolist (type (compoundtypetypes type))
 (accumulate1compoundtype type))
 (accumulate1compoundtype type)))
 (accumulate1compoundtype (type)
 (declare (type ctype type))
 ;; Any input object satisfying %COMPOUNDTYPEP should've been
 ;; broken into components before it reached us.
 (aver (not (funcall %compoundtypep type)))
 (dotimes (i (length types) (vectorpushextend type types))
 (let ((simplified2 (funcall simplify2 type (aref types i))))
 (when simplified2
 ;; Discard the old (AREF TYPES I).
 (setf (aref types i) (vectorpop types))
 ;; Merge the new SIMPLIFIED2 into TYPES, by tail recursing.
 ;; (Note that the tail recursion is indirect: we go through
 ;; ACCUMULATE, not ACCUMULATE1, so that if SIMPLIFIED2 is
 ;; handled properly if it satisfies %COMPOUNDTYPEP.)
 (return (accumulatecompoundtype simplified2)))))))
 (dolist (inputtype inputtypes)
 (accumulatecompoundtype inputtype)))
 types))

;;; shared logic for unions and intersections: Make a COMPOUNDTYPE
;;; object whose components are the types in TYPES, or skip to special
;;; cases when TYPES is short.
(defun makeprobablycompoundtype (constructor types enumerable identity)
 (declare (type function constructor))
 (declare (type (vector ctype) types))
 (declare (type ctype identity))
 (case (length types)
 (0 identity)
 (1 (aref types 0))
 (t (funcall constructor
 enumerable
 ;; FIXME: This should be just (COERCE TYPES 'LIST), but as
 ;; of sbcl0.6.11.17 the COERCE optimizer is really
 ;; braindead, so that would generate a full call to
 ;; SPECIFIERTYPE at runtime, so we get into bootstrap
 ;; problems in cold init because 'LIST is a compound
 ;; type, so we need to MAKEPROBABLYCOMPOUNDTYPE
 ;; before we know what 'LIST is. Once the COERCE
 ;; optimizer is less braindead, we can make this
 ;; (COERCE TYPES 'LIST) again.
 #+sbxchost (coerce types 'list)
 #sbxchost (coercetolist types)))))

+(macrolet
+ ((def (name compoundtypep simplify2)
+ `(defun ,name (types)
+ (when types
+ (multiplevaluebind (first rest)
+ (if (,compoundtypep (car types))
+ (values (car (compoundtypetypes (car types)))
+ (append (cdr (compoundtypetypes (car types)))
+ (cdr types)))
+ (values (car types) (cdr types)))
+ (let ((rest (,name rest)) u)
+ (dolist (r rest (cons first rest))
+ (when (setq u (,simplify2 first r))
+ (return (,name (nsubstitute u r rest)))))))))))
+ (def simplifyintersections intersectiontypep typeintersection2)
+ (def simplifyunions uniontypep typeunion2))
+
(defun maybedistributeoneunion (uniontype types)
(let* ((intersection (apply #'typeintersection types))
(union (mapcar (lambda (x) (typeintersection x intersection))
@@ 1002,10 +964,8 @@
:hashfunction (lambda (x)
(logand (sxhash x) #xff)))
((inputtypes equal))
 (let ((simplifiedtypes (simplifiedcompoundtypes inputtypes
 #'intersectiontypep
 #'typeintersection2)))
 (declare (type (vector ctype) simplifiedtypes))
+ (let ((simplifiedtypes (simplifyintersections inputtypes)))
+ (declare (type list simplifiedtypes))
;; We want to have a canonical representation of types (or failing
;; that, punt to HAIRYTYPE). Canonical representation would have
;; intersections inside unions but not vice versa, since you can
@@ 1014,8 +974,7 @@
;; to end up with unreasonably huge type expressions. So instead
;; we try to generate a simple type by distributing the union; if
;; the type can't be made simple, we punt to HAIRYTYPE.
 (if (and (> (length simplifiedtypes) 1)
 (some #'uniontypep simplifiedtypes))
+ (if (and (cdr simplifiedtypes) (some #'uniontypep simplifiedtypes))
(let* ((firstunion (findif #'uniontypep simplifiedtypes))
(othertypes (coerce (remove firstunion simplifiedtypes)
'list))
@@ 1027,11 +986,12 @@
:specifier `(and ,@(map 'list
#'typespecifier
simplifiedtypes)))))
 (makeprobablycompoundtype #'%makeintersectiontype
 simplifiedtypes
 (some #'typeenumerable
 simplifiedtypes)
 *universaltype*))))
+ (cond
+ ((null simplifiedtypes) *universaltype*)
+ ((null (cdr simplifiedtypes)) (car simplifiedtypes))
+ (t (%makeintersectiontype
+ (some #'typeenumerable simplifiedtypes)
+ simplifiedtypes))))))
(defun typeunion (&rest inputtypes)
(%typeunion inputtypes))
@@ 1039,13 +999,13 @@
:hashfunction (lambda (x)
(logand (sxhash x) #xff)))
((inputtypes equal))
 (let ((simplifiedtypes (simplifiedcompoundtypes inputtypes
 #'uniontypep
 #'typeunion2)))
 (makeprobablycompoundtype #'makeuniontype
 simplifiedtypes
 (every #'typeenumerable simplifiedtypes)
 *emptytype*)))
+ (let ((simplifiedtypes (simplifyunions inputtypes)))
+ (cond
+ ((null simplifiedtypes) *emptytype*)
+ ((null (cdr simplifiedtypes)) (car simplifiedtypes))
+ (t (makeuniontype
+ (every #'typeenumerable simplifiedtypes)
+ simplifiedtypes)))))
;;;; builtin types