From 04807f2266436e42e341be883cf9fb2b5782a4b4 Mon Sep 17 00:00:00 2001
From: Juan Jose Garcia Ripoll <jjgarcia@jjgr-2.local>
Date: Mon, 1 Dec 2008 19:38:58 +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/CHANGELOG       |  4 ++++
 src/cmp/cmptype.lsp | 21 ++++++++++++++++-----
 src/lsp/predlib.lsp | 12 ++++++++----
 3 files changed, 28 insertions(+), 9 deletions(-)

diff --git a/src/CHANGELOG b/src/CHANGELOG
index f0bc9d4bc..03a27dbd1 100644
--- a/src/CHANGELOG
+++ b/src/CHANGELOG
@@ -177,6 +177,10 @@ ECL 8.9.0:
 
  - ENSURE-DIRECTORIES first has to merge the path with *DEFAULT-PATH...*
 
+ - SUBTYPEP does not support complex CONS type specifiers. This caused the
+   compiler to choke on declaration such as (CONS INTEGER (CONS T T))
+   and the like.
+
 ;;; Local Variables: ***
 ;;; mode:text ***
 ;;; fill-column:79 ***
diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp
index dd44b09ab..5d6512ef4 100644
--- a/src/cmp/cmptype.lsp
+++ b/src/cmp/cmptype.lsp
@@ -143,12 +143,17 @@
 		  t2)
 		 (t
 		  `(AND ,t1 ,t2))))
+	  ((eq tag1 'CONS)
+	   (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1)
+	   t2)
+	  ((eq tag2 'CONS)
+	   (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
+	   t1)
 	  ((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,12 +177,18 @@
 		  t1)
 		 (t
 		  `(OR ,t1 ,t2))))
+	  ((eq tag1 'CONS)
+	   (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1)
+	   T)
+	  ((eq tag2 'CONS)
+	   (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
+	   T)
 	  ((null tag1)
 	   (cmpwarn "Unknown type ~S" t1)
-	   'T)
+	   T)
 	  (t
 	   (cmpwarn "Unknown type ~S" t2)
-	   'T))))
+	   T))))
 
 (defun type>= (type1 type2)
   (subtypep type2 type1))
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