From a6661cdaac013752213d381aa469cb0919a6ce4c Mon Sep 17 00:00:00 2001
From: Stas Boukarev <stassats@gmail.com>
Date: Mon, 3 Jun 2013 18:25:19 +0400
Subject: [PATCH] Fix APPEND/NCONC type derivation properly this time.

Use type-intersection for checking types, it's more robust than what
was there before.

And a slight improvement. When argument in the middle can't be a NIL,
then the end result is guaranteed to be a CONS. Previously, the
assumption was if the type is a CONS, but that doesn't work with types
like (or cons vector).
---
 src/compiler/srctran.lisp |   13 ++++++-------
 tests/compiler.pure.lisp  |    8 ++++++--
 2 files changed, 12 insertions(+), 9 deletions(-)

diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index 82be1f2..997e50b 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -176,12 +176,11 @@
             (loop for (arg next) on args
                   while next
                   do
-                  (let ((lvar-type (lvar-type arg)))
-                    (unless (or (csubtypep cons-type lvar-type)
-                                (csubtypep null-type lvar-type))
-                      (assert-lvar-type arg list-type
-                                        (lexenv-policy *lexenv*))
-                      (return *empty-type*))))
+                  (when (eq (type-intersection (lvar-type arg) list-type)
+                            *empty-type*)
+                    (assert-lvar-type arg list-type
+                                      (lexenv-policy *lexenv*))
+                    (return *empty-type*)))
             (loop with all-nil = t
                   for (arg next) on args
                   for lvar-type = (lvar-type arg)
@@ -189,7 +188,7 @@
                   do
                   (cond
                     ;; Cons in the middle guarantees the result will be a cons
-                    ((csubtypep lvar-type cons-type)
+                    ((not (csubtypep null-type lvar-type))
                      (return cons-type))
                     ;; If all but the last are NIL the type of the last arg
                     ;; can be used
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index b0c405a..90d0775 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4410,9 +4410,13 @@
             (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 (or cons vector) x) y)) cons
             (lambda (x y) (nconc (the sequence x) y)) t
-            (lambda (x y) (print (length y)) (append x y)) sequence)))
+            (lambda (x y) (print (length y)) (append x y)) sequence
+            (lambda (x y) (print (length y)) (append x y)) sequence
+            (lambda (x y) (append (the (member (a) (b)) x) y)) cons
+            (lambda (x y) (append (the (member (a) (b) c) x) y)) cons
+            (lambda (x y) (append (the (member (a) (b) nil) x) y)) t)))
     (loop for (function result-type) on test-cases by #'cddr
           do (assert (equal (car (cdaddr (sb-kernel:%simple-fun-type
                                           (compile nil function))))
-- 
1.7.10.4