From 2d9f16cae433893066dacd7d3a7f5af94ecf53f6 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Wed, 5 Jun 1991 10:58:50 +0000
Subject: [PATCH] Fixed the make-array derive type optimizer to only spec the
 dimensions if the created array is known to be simple.  Otherwise, someone
 might adjust it, which would cause the type to be wrong.

---
 compiler/array-tran.lisp | 43 ++++++++++++++++++++--------------------
 1 file changed, 22 insertions(+), 21 deletions(-)

diff --git a/compiler/array-tran.lisp b/compiler/array-tran.lisp
index 20f92d0f3..fbab7e948 100644
--- a/compiler/array-tran.lisp
+++ b/compiler/array-tran.lisp
@@ -7,11 +7,11 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/array-tran.lisp,v 1.10 1991/04/24 23:51:00 ram Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/array-tran.lisp,v 1.11 1991/06/05 10:58:50 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/array-tran.lisp,v 1.10 1991/04/24 23:51:00 ram Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/array-tran.lisp,v 1.11 1991/06/05 10:58:50 wlott Exp $
 ;;;
 ;;; This file contains array specific optimizers and transforms.
 ;;; 
@@ -130,25 +130,26 @@
 (defoptimizer (make-array derive-type)
 	      ((dims &key initial-element element-type initial-contents
 		adjustable fill-pointer displaced-index-offset displaced-to))
-  (specifier-type
-   `(,(if (and (unsupplied-or-nil adjustable)
-	       (unsupplied-or-nil displaced-to)
-	       (unsupplied-or-nil fill-pointer))
-	  'simple-array
-	  'array)
-     ,(cond ((not element-type) 't)
-	    ((constant-continuation-p element-type)
-	     (continuation-value element-type))
-	    (t
-	     '*))
-     ,(cond ((constant-continuation-p dims)
-	     (let ((val (continuation-value dims)))
-	       (if (listp val) val (list val))))
-	    ((csubtypep (continuation-type dims)
-			(specifier-type 'integer))
-	     '(*))
-	    (t
-	     '*)))))
+  (let ((simple (and (unsupplied-or-nil adjustable)
+		     (unsupplied-or-nil displaced-to)
+		     (unsupplied-or-nil fill-pointer))))
+    (specifier-type
+     `(,(if simple 'simple-array 'array)
+       ,(cond ((not element-type) 't)
+	      ((constant-continuation-p element-type)
+	       (continuation-value element-type))
+	      (t
+	       '*))
+       ,(cond ((not simple)
+	       '*)
+	      ((constant-continuation-p dims)
+	       (let ((val (continuation-value dims)))
+		 (if (listp val) val (list val))))
+	      ((csubtypep (continuation-type dims)
+			  (specifier-type 'integer))
+	       '(*))
+	      (t
+	       '*))))))
 
 
 ;;;; Constructors.
-- 
GitLab