From b0f45727fb6b7ff2b7ae2d2c63688a33d72aaab9 Mon Sep 17 00:00:00 2001
From: gerd <gerd>
Date: Thu, 3 Jul 2003 18:44:03 +0000
Subject: [PATCH]         (compile nil '(lambda (x) (typep x '(not (member
 0d0))))) recurses 	infinitely.  The same symptom could be observed when
 compiling 	CLOCC's cllib:rnd.lisp.  From Alexey Dejneka on cmucl-imp.

	* src/compiler/typetran.lisp (source-transform-union-typep):
	Produce (or (listp ...) ...) only if a member-type is among the
	union types, that member-type contains nil, and the rest of
	union types contains the cons type.
---
 compiler/typetran.lisp | 28 +++++++++++++++-------------
 1 file changed, 15 insertions(+), 13 deletions(-)

diff --git a/compiler/typetran.lisp b/compiler/typetran.lisp
index bd9d16d0d..2badef9e2 100644
--- a/compiler/typetran.lisp
+++ b/compiler/typetran.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/compiler/typetran.lisp,v 1.43 2003/04/27 14:52:27 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/typetran.lisp,v 1.44 2003/07/03 18:44:03 gerd Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -274,18 +274,20 @@
 ;;;
 (defun source-transform-union-typep (object type)
   (let* ((types (union-type-types type))
-	 (ltype (specifier-type 'list))
-	 (mtype (find-if #'member-type-p types)))
-    (cond ((and mtype (csubtypep ltype type))
-	   (let ((members (member-type-members mtype)))
-	     (once-only ((n-obj object))
-	       `(if (listp ,n-obj)
-		    t
-		    (typep ,n-obj 
-			   '(or ,@(mapcar #'type-specifier
-					  (remove (specifier-type 'cons)
-						  (remove mtype types)))
-				(member ,@(remove nil members))))))))
+	 (list-type (specifier-type 'list))
+	 (cons-type (specifier-type 'cons))
+	 (mtype (find-if #'member-type-p types))
+	 (members (when mtype (member-type-members mtype))))
+    (cond ((and mtype 
+		(memq nil members)
+		(memq cons-type types))
+	   (once-only ((n-obj object))
+	     `(or (listp ,n-obj)
+		  (typep ,n-obj 
+			 '(or ,@(mapcar #'type-specifier
+				        (remove cons-type
+					        (remove mtype types)))
+			   (member ,@(remove nil members)))))))
 	  (t
 	   (once-only ((n-obj object))
 	     `(or ,@(mapcar #'(lambda (x)
-- 
GitLab