From 7fbf559019c59487018417f434d8d9610246ac70 Mon Sep 17 00:00:00 2001
From: toy <toy>
Date: Tue, 15 Oct 2002 21:23:14 +0000
Subject: [PATCH] Port over SBCL's fix for the Entomotomy bug

array-element-type-treated-as-declaration

wherein the compiler believes type declarations on array elements
without checking them, e.g.

	(DECLAIM (OPTIMIZE (SAFETY 3) (SPEED 1) (SPACE 1)))
	(DEFSTRUCT FOO A B)
	(DEFUN BAR (X)
	  (DECLARE (TYPE (SIMPLE-ARRAY CONS 1) X))
	  (WHEN (CONSP (AREF X 0))
	    (PRINT (AREF X 0))))
	(BAR (VECTOR (MAKE-FOO :A 11 :B 12)))

prints a structure out.

This patch makes the compiler use the specialized (upgraded) element
type instead of the declared element type for aref.
---
 compiler/array-tran.lisp      | 6 +++---
 compiler/generic/vm-tran.lisp | 6 +++---
 2 files changed, 6 insertions(+), 6 deletions(-)

diff --git a/compiler/array-tran.lisp b/compiler/array-tran.lisp
index d37325ab3..2f3b45f29 100644
--- a/compiler/array-tran.lisp
+++ b/compiler/array-tran.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/array-tran.lisp,v 1.28 2000/07/06 18:37:00 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/array-tran.lisp,v 1.29 2002/10/15 21:23:13 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -59,7 +59,7 @@
   (let ((type (continuation-type array)))
     (when (array-type-p type)
       (assert-continuation-optional-type new-value
-					 (array-type-element-type type))))
+					 (array-type-specialized-element-type type))))
   (continuation-type new-value))
 
 ;;; Unsupplied-Or-NIL  --  Internal
@@ -87,7 +87,7 @@
   ;; If the node continuation has a single use then assert its type.
   (let ((cont (node-cont node)))
     (when (= (length (find-uses cont)) 1)
-      (assert-continuation-type cont (extract-element-type array))))
+      (assert-continuation-type cont (extract-upgraded-element-type array))))
   (extract-upgraded-element-type array))
 
 ;;; %ASET  --  derive-type optimizer.
diff --git a/compiler/generic/vm-tran.lisp b/compiler/generic/vm-tran.lisp
index edadb6b2c..9eb24c879 100644
--- a/compiler/generic/vm-tran.lisp
+++ b/compiler/generic/vm-tran.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/generic/vm-tran.lisp,v 1.45 2002/08/08 15:37:38 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.46 2002/10/15 21:23:14 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -59,7 +59,7 @@
     (let ((dims (array-type-dimensions array-type)))
       (when (and (consp dims) (= (length dims) 1))
 	(give-up))
-      (let* ((el-type (array-type-element-type array-type))
+      (let* ((el-type (array-type-specialized-element-type array-type))
 	     (total-size (if (or (atom dims) (member '* dims))
 			     '*
 			     (reduce #'* dims)))
@@ -84,7 +84,7 @@
       (give-up))
     (delay-transform node :optimize)
     (let* ((dims (array-type-dimensions array-type))
-	   (el-type (array-type-element-type array-type))
+	   (el-type (array-type-specialized-element-type array-type))
 	   (total-size (if (or (atom dims) (member '* dims))
 			   '*
 			   (reduce #'* dims)))
-- 
GitLab