Skip to content
Snippets Groups Projects
Commit b0f45727 authored by gerd's avatar gerd
Browse files

(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.
parent 5d2d04f0
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -274,18 +274,20 @@
;;; ;;;
(defun source-transform-union-typep (object type) (defun source-transform-union-typep (object type)
(let* ((types (union-type-types type)) (let* ((types (union-type-types type))
(ltype (specifier-type 'list)) (list-type (specifier-type 'list))
(mtype (find-if #'member-type-p types))) (cons-type (specifier-type 'cons))
(cond ((and mtype (csubtypep ltype type)) (mtype (find-if #'member-type-p types))
(let ((members (member-type-members mtype))) (members (when mtype (member-type-members mtype))))
(once-only ((n-obj object)) (cond ((and mtype
`(if (listp ,n-obj) (memq nil members)
t (memq cons-type types))
(typep ,n-obj (once-only ((n-obj object))
'(or ,@(mapcar #'type-specifier `(or (listp ,n-obj)
(remove (specifier-type 'cons) (typep ,n-obj
(remove mtype types))) '(or ,@(mapcar #'type-specifier
(member ,@(remove nil members)))))))) (remove cons-type
(remove mtype types)))
(member ,@(remove nil members)))))))
(t (t
(once-only ((n-obj object)) (once-only ((n-obj object))
`(or ,@(mapcar #'(lambda (x) `(or ,@(mapcar #'(lambda (x)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment