From 044caf8c4d34b7532a88bf8f2855d68a80d126fc Mon Sep 17 00:00:00 2001
From: Juan Jose Garcia Ripoll <jjgarcia@jjgr-2.local>
Date: Sun, 30 Nov 2008 22:28:51 +0100
Subject: [PATCH] SUBTYPEP must abort on finding a complex CONS type, but this
 should not affect the TYPE-AND and TYPE-OR routines.

---
 src/c/file.d        |  8 ++++----
 src/cmp/cmptype.lsp | 13 ++++++++++---
 src/lsp/predlib.lsp | 12 ++++++++----
 3 files changed, 22 insertions(+), 11 deletions(-)

diff --git a/src/c/file.d b/src/c/file.d
index d04d67c8d..155f887cf 100644
--- a/src/c/file.d
+++ b/src/c/file.d
@@ -2206,8 +2206,7 @@ io_file_read_vector(cl_object strm, cl_object data, cl_index start, cl_index end
 			void *aux = data->vector.self.ch + start;
 			return strm->stream.ops->read_byte8(strm, aux, end-start);
 		}
-	}
-	if (t == aet_fix || t == aet_index) {
+	} else if (t == aet_fix || t == aet_index) {
 		if (strm->stream.byte_size == sizeof(cl_fixnum)*8) {
 			void *aux = data->vector.self.fix + start;
 			cl_index bytes = (end - start) * sizeof(cl_fixnum);
@@ -2229,8 +2228,7 @@ io_file_write_vector(cl_object strm, cl_object data, cl_index start, cl_index en
 			void *aux = data->vector.self.fix + start;
 			return strm->stream.ops->write_byte8(strm, aux, end-start);
 		}
-	}
-	if (t == aet_fix || t == aet_index) {
+	} else if (t == aet_fix || t == aet_index) {
 		if (strm->stream.byte_size == sizeof(cl_fixnum)*8) {
 			void *aux = data->vector.self.fix + start;
 			cl_index bytes = (end - start) * sizeof(cl_fixnum);
@@ -2347,6 +2345,8 @@ set_stream_elt_type(cl_object stream, cl_fixnum byte_size, int flags)
 	case ECL_STREAM_BINARY:
 		IO_STREAM_ELT_TYPE(stream) = cl_list(2, t, MAKE_FIXNUM(byte_size));
 		stream->stream.format = @':default';
+		stream->stream.ops->read_char = not_character_read_char;
+		stream->stream.ops->write_char = not_character_write_char;
 		break;
 	/*case ECL_ISO_8859_1:*/
 	case ECL_STREAM_LATIN_1:
diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp
index dd44b09ab..7dfba46b7 100644
--- a/src/cmp/cmptype.lsp
+++ b/src/cmp/cmptype.lsp
@@ -143,12 +143,15 @@
 		  t2)
 		 (t
 		  `(AND ,t1 ,t2))))
+	  ((eq tag1 'CONS)
+	   (type-and 'CONS t2))
+	  ((eq tag2 'CONS)
+	   (type-and t1 'CONS))
 	  ((null tag1)
-	   (cmpwarn "Unknown type ~S" t1)
+	   (cmpwarn "Unknown type ~S. Assuming it is T." t1)
 	   t2)
 	  (t
-	   (error t2)
-	   (cmpwarn "Unknown type ~S" t2)
+	   (cmpwarn "Unknown type ~S. Assuming it is T." t2)
 	   t1))))
 
 (defun type-or (t1 t2)
@@ -172,6 +175,10 @@
 		  t1)
 		 (t
 		  `(OR ,t1 ,t2))))
+	  ((eq tag1 'CONS)
+	   (type-or 'CONS t2))
+	  ((eq tag2 'CONS)
+	   (type-or t1 'CONS))
 	  ((null tag1)
 	   (cmpwarn "Unknown type ~S" t1)
 	   'T)
diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp
index 55bac0324..d02859b07 100644
--- a/src/lsp/predlib.lsp
+++ b/src/lsp/predlib.lsp
@@ -753,8 +753,9 @@ if not possible."
   (or (find-registered-tag type)
       (multiple-value-bind (tag-super tag-sub)
 	  (find-type-bounds type in-our-family-p type-<= nil)
-	(let ((tag (logior (new-type-tag) tag-sub)))
+	(let ((tag (new-type-tag)))
 	  (update-types (logandc2 tag-super tag-sub) tag)
+	  (setf tag (logior tag tag-sub))
 	  (push-type type tag)
 	  tag))))
 
@@ -1064,9 +1065,12 @@ if not possible."
 (defun register-cons-type (&optional (car-type '*) (cdr-type '*))
   (let ((car-tag (if (eq car-type '*) -1 (canonical-type car-type)))
 	(cdr-tag (if (eq cdr-type '*) -1 (canonical-type cdr-type))))
-    (if (or (zerop car-tag) (zerop cdr-tag))
-	0
-	(canonical-type 'CONS))))
+    (cond ((or (zerop car-tag) (zerop cdr-tag))
+	   0)
+	  ((and (= car-tag -1) (= cdr-tag -1))
+	   (canonical-type 'CONS))
+	  (t
+	   (throw '+canonical-type-failure+ 'CONS)))))
 
 ;;----------------------------------------------------------------------
 ;; FIND-BUILT-IN-TAG