Skip to content
Snippets Groups Projects
Commit fa1d20f2 authored by rtoy's avatar rtoy
Browse files

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.
parent e67c0397
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -60,20 +60,23 @@
(when (and (consp dims) (= (length dims) 1)) (when (and (consp dims) (= (length dims) 1))
(give-up)) (give-up))
(let* ((el-type (array-type-specialized-element-type array-type)) (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)) (total-size (if (or (atom dims) (member '* dims))
'* '*
(reduce #'* dims))) (reduce #'* dims)))
(vector-type `(simple-array ,(type-specifier el-type) (vector-type `(simple-array ,(type-specifier el-type)
(,total-size)))) (,total-size))))
(if (atom dims) (if (atom dims)
`(data-vector-ref (truly-the ,vector-type `(the ,(type-specifier declared-type)
(if (array-header-p array) (data-vector-ref (truly-the ,vector-type
(%array-data-vector array) (if (array-header-p array)
array)) (%array-data-vector array)
index) array))
`(data-vector-ref (truly-the ,vector-type index))
(%array-data-vector array)) `(the ,(type-specifier declared-type)
index)))))) (data-vector-ref (truly-the ,vector-type
(%array-data-vector array))
index)))))))
(deftransform data-vector-ref ((array index) (array t) * (deftransform data-vector-ref ((array index) (array t) *
:node node :policy (> speed space)) :node node :policy (> speed space))
...@@ -85,6 +88,7 @@ ...@@ -85,6 +88,7 @@
(delay-transform node :optimize) (delay-transform node :optimize)
(let* ((dims (array-type-dimensions array-type)) (let* ((dims (array-type-dimensions array-type))
(el-type (array-type-specialized-element-type 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)) (total-size (if (or (atom dims) (member '* dims))
'* '*
(reduce #'* dims))) (reduce #'* dims)))
...@@ -93,12 +97,14 @@ ...@@ -93,12 +97,14 @@
(if (and (consp dims) (> (length dims) 1)) (if (and (consp dims) (> (length dims) 1))
`(multiple-value-bind (vector index) `(multiple-value-bind (vector index)
(%with-array-data array index nil) (%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) `(multiple-value-bind (vector index)
(if (array-header-p array) (if (array-header-p array)
(%with-array-data array index nil) (%with-array-data array index nil)
(values array index)) (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) (deftransform data-vector-set ((array index new-value)
(simple-array t t)) (simple-array t t))
...@@ -109,6 +115,7 @@ ...@@ -109,6 +115,7 @@
(when (and (consp dims) (= (length dims) 1)) (when (and (consp dims) (= (length dims) 1))
(give-up)) (give-up))
(let* ((el-type (array-type-element-type array-type)) (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)) (total-size (if (or (atom dims) (member '* dims))
'* '*
(reduce #'* dims))) (reduce #'* dims)))
...@@ -120,11 +127,11 @@ ...@@ -120,11 +127,11 @@
(%array-data-vector array) (%array-data-vector array)
array)) array))
index index
new-value) (the ,(type-specifier declared-type) new-value))
`(data-vector-set (truly-the ,vector-type `(data-vector-set (truly-the ,vector-type
(%array-data-vector array)) (%array-data-vector array))
index index
new-value)))))) (the ,(type-specifier declared-type) new-value)))))))
(deftransform data-vector-set ((array index new-value) (array t t) * (deftransform data-vector-set ((array index new-value) (array t t) *
:node node :policy (> speed space)) :node node :policy (> speed space))
...@@ -136,6 +143,7 @@ ...@@ -136,6 +143,7 @@
(delay-transform node :optimize) (delay-transform node :optimize)
(let* ((dims (array-type-dimensions array-type)) (let* ((dims (array-type-dimensions array-type))
(el-type (array-type-element-type 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)) (total-size (if (or (atom dims) (member '* dims))
'* '*
(reduce #'* dims))) (reduce #'* dims)))
...@@ -146,14 +154,14 @@ ...@@ -146,14 +154,14 @@
(%with-array-data array index nil) (%with-array-data array index nil)
(data-vector-set (truly-the ,vector-type vector) (data-vector-set (truly-the ,vector-type vector)
index index
new-value)) (the ,(type-specifier declared-type) new-value)))
`(multiple-value-bind (vector index) `(multiple-value-bind (vector index)
(if (array-header-p array) (if (array-header-p array)
(%with-array-data array index nil) (%with-array-data array index nil)
(values array index)) (values array index))
(data-vector-set (truly-the ,vector-type vector) (data-vector-set (truly-the ,vector-type vector)
index index
new-value)))))) (the ,(type-specifier declared-type) new-value)))))))
;;; Transforms for getting at arrays of unsigned-byte n when n < 8. ;;; Transforms for getting at arrays of unsigned-byte n when n < 8.
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment