diff --git a/compiler/typetran.lisp b/compiler/typetran.lisp index bd9d16d0d98dc8858722d9edc4e6a7e4bca41ceb..2badef9e2ee5b916ffd3cfa793e56b7dfa35bc06 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)