diff --git a/code/type.lisp b/code/type.lisp index af19d71cd79ff5eb8e655852873d898b5e224c23..537c7b1786c1054de2911a89d0929dd202d3b1d2 100644 --- a/code/type.lisp +++ b/code/type.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.64 2003/08/04 17:30:03 gerd Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/type.lisp,v 1.65 2003/10/09 15:50:01 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -3175,13 +3175,20 @@ (define-type-method (cons :simple-intersection) (type1 type2) (declare (type cons-type type1 type2)) - (let (car-int2 - cdr-int2) - (and (setf car-int2 (type-intersection2 (cons-type-car-type type1) - (cons-type-car-type type2))) - (setf cdr-int2 (type-intersection2 (cons-type-cdr-type type1) - (cons-type-cdr-type type2))) - (make-cons-type car-int2 cdr-int2)))) + (let ((car-int2 (type-intersection2 (cons-type-car-type type1) + (cons-type-car-type type2))) + (cdr-int2 (type-intersection2 (cons-type-cdr-type type1) + (cons-type-cdr-type type2)))) + (cond ((and car-int2 cdr-int2) + (make-cons-type car-int2 cdr-int2)) + (car-int2 + (make-cons-type car-int2 + (type-intersection (cons-type-cdr-type type1) + (cons-type-cdr-type type2)))) + (cdr-int2 + (make-cons-type (type-intersection (cons-type-car-type type1) + (cons-type-car-type type2)) + cdr-int2))))) ;;; TYPE-DIFFERENCE -- Interface