From: Stas Boukarev <stassats@gmail.com>
Date: Mon, 3 Jun 2013 11:28:02 +0000 (+0400)
Subject: Fix NCONC type derivation.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=123a8dd97ab99b5e205b6768f6389d7cc7c12656;p=sbcl.git

Fix NCONC type derivation.

Properly check the types of arguments, instead of testing for subtypes
or supertypes of LIST, check for arguments to be subtypes of NULL or CONS.

Reported by Jerry James.
---

diff --git a/NEWS b/NEWS
index 45b6aec..0bcf148 100644
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,7 @@
 changes relative to sbcl-1.1.8:
   * enchancement: disassemble now annotates some previously missing static
     functions, like LENGTH.
+  * bug fix: problems with NCONC type derivation (reported by Jerry James).
   * optimization: calls to static functions on x86-64 use less instructions.
   * optimization: compute encode-universal-time at compile time when possible.
   * optimization: when referencing internal functions as #'x, don't go through
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index cc6b36d..82be1f2 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -177,10 +177,7 @@
                   while next
                   do
                   (let ((lvar-type (lvar-type arg)))
-                    (unless (or (csubtypep list-type lvar-type)
-                                (csubtypep lvar-type list-type)
-                                ;; Check for NIL specifically, because
-                                ;; SYMBOL or ATOM won't satisfie the above
+                    (unless (or (csubtypep cons-type lvar-type)
                                 (csubtypep null-type lvar-type))
                       (assert-lvar-type arg list-type
                                         (lexenv-policy *lexenv*))
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index f30c809..b0c405a 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4410,6 +4410,8 @@
             (lambda (x y) (nconc x (the list y) x)) t
             (lambda (x y) (nconc (the atom x) y)) t
             (lambda (x y) (nconc (the (or null (eql 10)) x) y)) t
+            (lambda (x y) (nconc (the (or cons vector) x) y)) t
+            (lambda (x y) (nconc (the sequence x) y)) t
             (lambda (x y) (print (length y)) (append x y)) sequence)))
     (loop for (function result-type) on test-cases by #'cddr
           do (assert (equal (car (cdaddr (sb-kernel:%simple-fun-type