From 73cda57844fb13432c6dcd9e08a31f6a0a4de646 Mon Sep 17 00:00:00 2001
From: toy <toy>
Date: Wed, 30 Jul 2003 15:33:05 +0000
Subject: [PATCH] Port of SBCL patch by Christophe Rhodes to make
 MAKE-SEQUENCE, CONCATENATE, and MERGE derive their result types better. 
 Basically, return type (VECTOR T) if VECTOR is given.

---
 compiler/knownfun.lisp | 21 +++++++++++++++++++--
 1 file changed, 19 insertions(+), 2 deletions(-)

diff --git a/compiler/knownfun.lisp b/compiler/knownfun.lisp
index 3f7a07430..287c807d4 100644
--- a/compiler/knownfun.lisp
+++ b/compiler/knownfun.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/knownfun.lisp,v 1.23 2003/06/06 16:23:46 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/knownfun.lisp,v 1.24 2003/07/30 15:33:05 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -291,7 +291,24 @@
       (declare (type combination call))
       (let ((cont (nth (1- n) (combination-args call))))
 	(when (and cont (constant-continuation-p cont))
-	  (specifier-type (continuation-value cont))))))
+	  (let ((ctype (specifier-type (continuation-value cont))))
+	    ;; If ctype is an array with element type *wild-type* (*),
+	    ;; convert it to an array with element type
+	    ;; *universal-type* (T).  (Because this function is only
+	    ;; used where vectors are really (vector t).)
+	    (if (and (array-type-p ctype)
+		     (eq (array-type-specialized-element-type ctype)
+			    *wild-type*))
+		   ;; I don't think I'm allowed to modify what I get
+		   ;; back from SPECIFIER-TYPE; it is, after all,
+		   ;; cached.  Better copy it, then.
+		   (let ((real-ctype (copy-structure ctype)))
+		     (setf (array-type-element-type real-ctype)
+			   *universal-type*
+			   (array-type-specialized-element-type real-ctype)
+			   *universal-type*)
+		     real-ctype)
+		   ctype))))))
 
 ;;; RESULT-TYPE-OPEN-CLASS  --  Interface
 ;;;
-- 
GitLab