From 7ca7485031fafc3223e21d4b65df3ba5486df813 Mon Sep 17 00:00:00 2001
From: toy <toy>
Date: Tue, 15 Oct 2002 16:36:51 +0000
Subject: [PATCH] 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.
---
 compiler/constraint.lisp | 91 ++++++++++++++++++++--------------------
 1 file changed, 46 insertions(+), 45 deletions(-)

diff --git a/compiler/constraint.lisp b/compiler/constraint.lisp
index 7625c5cd5..d445196a2 100644
--- a/compiler/constraint.lisp
+++ b/compiler/constraint.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/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 @@
      (add-complement-constraints if 'typep (ok-ref-lambda-var use)
 				 *null-type* t))
     (combination
-     (let ((name (continuation-function-name
-		  (basic-combination-fun use)))
-	   (args (basic-combination-args use)))
-       (case name
-	 ((%typep %instance-typep)
-	  (let ((type (second args)))
-	    (when (constant-continuation-p type)
-	      (let ((val (continuation-value type)))
-	      (add-complement-constraints if 'typep
-					  (ok-cont-lambda-var (first args))
-					  (if (ctype-p val)
-					      val
-					      (specifier-type val))
-					  nil)))))
-	 ((eq eql)
-	  (let* ((var1 (ok-cont-lambda-var (first args)))
-		 (arg2 (second args))
-		 (var2 (ok-cont-lambda-var arg2)))
-	    (cond ((not var1))
-		  (var2
-		   (add-complement-constraints if 'eql var1 var2 nil))
-		  ((constant-continuation-p arg2)
-		   (add-complement-constraints if 'eql var1
-					       (ref-leaf
-						(continuation-use arg2))
-					       nil)))))
-	 ((< >)
-	  (let* ((arg1 (first args))
-		 (var1 (ok-cont-lambda-var arg1))
-		 (arg2 (second args))
-		 (var2 (ok-cont-lambda-var arg2)))
-	    (when var1
-	      (add-complement-constraints if name var1 (continuation-type arg2)
-					  nil))
-	    (when var2
-	      (add-complement-constraints if (if (eq name '<) '> '<)
-					  var2 (continuation-type arg1)
-					  nil))))
-	 (t
-	  (let ((ptype (gethash name (backend-predicate-types *backend*))))
-	    (when ptype
-	      (add-complement-constraints if 'typep
-					  (ok-cont-lambda-var (first args))
-					  ptype nil))))))))
+     (unless (eq (combination-kind use) :error)
+       (let ((name (continuation-function-name
+		    (basic-combination-fun use)))
+	     (args (basic-combination-args use)))
+	 (case name
+	   ((%typep %instance-typep)
+	    (let ((type (second args)))
+	      (when (constant-continuation-p type)
+		(let ((val (continuation-value type)))
+		  (add-complement-constraints if 'typep
+					      (ok-cont-lambda-var (first args))
+					      (if (ctype-p val)
+						  val
+						  (specifier-type val))
+					      nil)))))
+	   ((eq eql)
+	    (let* ((var1 (ok-cont-lambda-var (first args)))
+		   (arg2 (second args))
+		   (var2 (ok-cont-lambda-var arg2)))
+	      (cond ((not var1))
+		    (var2
+		     (add-complement-constraints if 'eql var1 var2 nil))
+		    ((constant-continuation-p arg2)
+		     (add-complement-constraints if 'eql var1
+						 (ref-leaf
+						  (continuation-use arg2))
+						 nil)))))
+	   ((< >)
+	    (let* ((arg1 (first args))
+		   (var1 (ok-cont-lambda-var arg1))
+		   (arg2 (second args))
+		   (var2 (ok-cont-lambda-var arg2)))
+	      (when var1
+		(add-complement-constraints if name var1 (continuation-type arg2)
+					    nil))
+	      (when var2
+		(add-complement-constraints if (if (eq name '<) '> '<)
+					    var2 (continuation-type arg1)
+					    nil))))
+	   (t
+	    (let ((ptype (gethash name (backend-predicate-types *backend*))))
+	      (when ptype
+		(add-complement-constraints if 'typep
+					    (ok-cont-lambda-var (first args))
+					    ptype nil)))))))))
   (undefined-value))
 
 	      
-- 
GitLab