0.7.1.30:

[sbcl.git] / src / compiler / constraint.lisp

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index a302245..e2be093 100644 (file)
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -126,50 +126,52 @@
      (add-complement-constraints if 'typep (ok-ref-lambda-var use)
                                 (specifier-type 'null) t))
     (combination
-     (let ((name (continuation-fun-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*)))
-           (when ptype
-             (add-complement-constraints if 'typep
-                                         (ok-cont-lambda-var (first args))
-                                         ptype nil))))))))
+     (unless (eq (combination-kind use)
+                 :error)
+       (let ((name (continuation-fun-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*)))
+              (when ptype
+                (add-complement-constraints if 'typep
+                                            (ok-cont-lambda-var (first args))
+                                            ptype nil)))))))))
   (values))
 
 ;;; Set the TEST-CONSTRAINT in the successors of BLOCK according to