X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fconstraint.lisp;h=eb936ba7098a6be81bcc608d9986b5e8f362e450;hb=568725aaf7d2d3dae486cd85210eb514c856fdb7;hp=de2beecd3c7f33f75fb9f5e4e3bde480cda0be52;hpb=da5a7ccd58c2bf3c5287a11fb41e01403e5745e8;p=sbcl.git

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index de2beec..eb936ba 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -158,7 +158,7 @@
                                #-sb-xc-host ignore
                                #-sb-xc-host constraint-universe-end)
       (let* ((constraint-universe #+sb-xc-host '*constraint-universe*
-                                  #-sb-xc-host (gensym))
+                                  #-sb-xc-host (sb!xc:gensym "UNIVERSE"))
              (with-array-data
                 #+sb-xc-host '(progn)
                 #-sb-xc-host `(with-array-data
@@ -357,7 +357,7 @@
       (let ((new (make-constraint (length *constraint-universe*)
                                   kind x y not-p)))
         (vector-push-extend new *constraint-universe*
-                            (* 2 (length *constraint-universe*)))
+                            (1+ (length *constraint-universe*)))
         (conset-adjoin new (lambda-var-constraints x))
         (when (lambda-var-p y)
           (conset-adjoin new (lambda-var-constraints y)))
@@ -468,7 +468,8 @@
                              (ok-lvar-lambda-var (first args) constraints)
                              (if (ctype-p val)
                                  val
-                                 (specifier-type val))
+                                 (let ((*compiler-error-context* use))
+                                   (specifier-type val)))
                              nil)))))
                  ((eq eql)
                   (let* ((arg1 (first args))
@@ -490,7 +491,11 @@
                           (var2
                            (add 'eql var1 var2 nil))
                           ((constant-lvar-p arg2)
-                           (add 'eql var1 (ref-leaf (principal-lvar-use arg2))
+                           (add 'eql var1
+                                (let ((use (principal-lvar-use arg2)))
+                                  (if (ref-p use)
+                                      (ref-leaf use)
+                                      (find-constant (lvar-value arg2))))
                                 nil))
                           (t
                            (add-test-constraint 'typep var1 (lvar-type arg2)