From fa1d20f23ced11d69f898dbc9f3caa68806e076b Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Tue, 25 Jan 2005 14:50:14 +0000
Subject: [PATCH] Add type checks (THE) to the data-vector-ref and
 data-vector-set deftransforms.  This causes a warning to be produced for

   (defun foo (f d)
     (declare (type (simple-array single-float (*)) f)
              (type (simple-array double-float (*)) d))
     (setf (aref f 0) (aref d 0)))

(from Lynn Quam, cmucl-imp 2004-03-30).  Previously, no warning was
produced and all code including the function return was deleted.  Now
a warning is produced and the code is not deleted.

This is a workaround.
---
 compiler/generic/vm-tran.lisp | 38 +++++++++++++++++++++--------------
 1 file changed, 23 insertions(+), 15 deletions(-)

diff --git a/compiler/generic/vm-tran.lisp b/compiler/generic/vm-tran.lisp
index 8b81723eb..0a8f4b63d 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.56 2004/10/04 20:27:06 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.57 2005/01/25 14:50:14 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -60,20 +60,23 @@
       (when (and (consp dims) (= (length dims) 1))
 	(give-up))
       (let* ((el-type (array-type-specialized-element-type array-type))
+	     (declared-type (array-type-element-type array-type))
 	     (total-size (if (or (atom dims) (member '* dims))
 			     '*
 			     (reduce #'* dims)))
 	     (vector-type `(simple-array ,(type-specifier el-type)
 					 (,total-size))))
 	(if (atom dims)
-	    `(data-vector-ref (truly-the ,vector-type
-					 (if (array-header-p array)
-					     (%array-data-vector array)
-					     array))
-			      index)
-	    `(data-vector-ref (truly-the ,vector-type
-					 (%array-data-vector array))
-			      index))))))
+	    `(the ,(type-specifier declared-type)
+	       (data-vector-ref (truly-the ,vector-type
+					   (if (array-header-p array)
+					       (%array-data-vector array)
+					       array))
+				index))
+	    `(the ,(type-specifier declared-type)
+	       (data-vector-ref (truly-the ,vector-type
+					   (%array-data-vector array))
+				index)))))))
 
 (deftransform data-vector-ref ((array index) (array t) *
 			       :node node  :policy (> speed space))
@@ -85,6 +88,7 @@
     (delay-transform node :optimize)
     (let* ((dims (array-type-dimensions array-type))
 	   (el-type (array-type-specialized-element-type array-type))
+	   (declared-type (array-type-element-type array-type))
 	   (total-size (if (or (atom dims) (member '* dims))
 			   '*
 			   (reduce #'* dims)))
@@ -93,12 +97,14 @@
       (if (and (consp dims) (> (length dims) 1))
 	  `(multiple-value-bind (vector index)
 	       (%with-array-data array index nil)
-	     (data-vector-ref (truly-the ,vector-type vector) index))
+	     (the ,(type-specifier declared-type)
+	       (data-vector-ref (truly-the ,vector-type vector) index)))
 	  `(multiple-value-bind (vector index)
 	       (if (array-header-p array)
 		   (%with-array-data array index nil)
 		   (values array index))
-	     (data-vector-ref (truly-the ,vector-type vector) index))))))
+	     (the ,(type-specifier declared-type)
+	       (data-vector-ref (truly-the ,vector-type vector) index)))))))
 
 (deftransform data-vector-set ((array index new-value)
 			       (simple-array t t))
@@ -109,6 +115,7 @@
       (when (and (consp dims) (= (length dims) 1))
 	(give-up))
       (let* ((el-type (array-type-element-type array-type))
+	     (declared-type (array-type-element-type array-type))
 	     (total-size (if (or (atom dims) (member '* dims))
 			     '*
 			     (reduce #'* dims)))
@@ -120,11 +127,11 @@
 					     (%array-data-vector array)
 					     array))
 			      index
-			      new-value)
+			      (the ,(type-specifier declared-type) new-value))
 	    `(data-vector-set (truly-the ,vector-type
 					 (%array-data-vector array))
 			      index
-			      new-value))))))
+			      (the ,(type-specifier declared-type) new-value)))))))
 
 (deftransform data-vector-set ((array index new-value) (array t t) *
 			       :node node  :policy (> speed space))
@@ -136,6 +143,7 @@
     (delay-transform node :optimize)
     (let* ((dims (array-type-dimensions array-type))
 	   (el-type (array-type-element-type array-type))
+	   (declared-type (array-type-element-type array-type))
 	   (total-size (if (or (atom dims) (member '* dims))
 			   '*
 			   (reduce #'* dims)))
@@ -146,14 +154,14 @@
 	       (%with-array-data array index nil)
 	     (data-vector-set (truly-the ,vector-type vector)
 			      index
-			      new-value))
+			      (the ,(type-specifier declared-type) new-value)))
 	  `(multiple-value-bind (vector index)
 	       (if (array-header-p array)
 		   (%with-array-data array index nil)
 		   (values array index))
 	     (data-vector-set (truly-the ,vector-type vector)
 			      index
-			      new-value))))))
+			      (the ,(type-specifier declared-type) new-value)))))))
 
 
 ;;; Transforms for getting at arrays of unsigned-byte n when n < 8.
-- 
GitLab