Skip to content
Snippets Groups Projects
Commit 7ca74850 authored by toy's avatar toy
Browse files

Port over SBCL's fix for the Entomotomy bug

eql-with-one-arg-fails-in-add-test-constraints

This occurs when EQL is given only one arg.
parent 072200bd
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/constraint.lisp,v 1.24 2002/08/25 19:01:28 toy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/constraint.lisp,v 1.25 2002/10/15 16:36:51 toy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -158,50 +158,51 @@ ...@@ -158,50 +158,51 @@
(add-complement-constraints if 'typep (ok-ref-lambda-var use) (add-complement-constraints if 'typep (ok-ref-lambda-var use)
*null-type* t)) *null-type* t))
(combination (combination
(let ((name (continuation-function-name (unless (eq (combination-kind use) :error)
(basic-combination-fun use))) (let ((name (continuation-function-name
(args (basic-combination-args use))) (basic-combination-fun use)))
(case name (args (basic-combination-args use)))
((%typep %instance-typep) (case name
(let ((type (second args))) ((%typep %instance-typep)
(when (constant-continuation-p type) (let ((type (second args)))
(let ((val (continuation-value type))) (when (constant-continuation-p type)
(add-complement-constraints if 'typep (let ((val (continuation-value type)))
(ok-cont-lambda-var (first args)) (add-complement-constraints if 'typep
(if (ctype-p val) (ok-cont-lambda-var (first args))
val (if (ctype-p val)
(specifier-type val)) val
nil))))) (specifier-type val))
((eq eql) nil)))))
(let* ((var1 (ok-cont-lambda-var (first args))) ((eq eql)
(arg2 (second args)) (let* ((var1 (ok-cont-lambda-var (first args)))
(var2 (ok-cont-lambda-var arg2))) (arg2 (second args))
(cond ((not var1)) (var2 (ok-cont-lambda-var arg2)))
(var2 (cond ((not var1))
(add-complement-constraints if 'eql var1 var2 nil)) (var2
((constant-continuation-p arg2) (add-complement-constraints if 'eql var1 var2 nil))
(add-complement-constraints if 'eql var1 ((constant-continuation-p arg2)
(ref-leaf (add-complement-constraints if 'eql var1
(continuation-use arg2)) (ref-leaf
nil))))) (continuation-use arg2))
((< >) nil)))))
(let* ((arg1 (first args)) ((< >)
(var1 (ok-cont-lambda-var arg1)) (let* ((arg1 (first args))
(arg2 (second args)) (var1 (ok-cont-lambda-var arg1))
(var2 (ok-cont-lambda-var arg2))) (arg2 (second args))
(when var1 (var2 (ok-cont-lambda-var arg2)))
(add-complement-constraints if name var1 (continuation-type arg2) (when var1
nil)) (add-complement-constraints if name var1 (continuation-type arg2)
(when var2 nil))
(add-complement-constraints if (if (eq name '<) '> '<) (when var2
var2 (continuation-type arg1) (add-complement-constraints if (if (eq name '<) '> '<)
nil)))) var2 (continuation-type arg1)
(t nil))))
(let ((ptype (gethash name (backend-predicate-types *backend*)))) (t
(when ptype (let ((ptype (gethash name (backend-predicate-types *backend*))))
(add-complement-constraints if 'typep (when ptype
(ok-cont-lambda-var (first args)) (add-complement-constraints if 'typep
ptype nil)))))))) (ok-cont-lambda-var (first args))
ptype nil)))))))))
(undefined-value)) (undefined-value))
......
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