diff --git a/compiler/array-tran.lisp b/compiler/array-tran.lisp
index d237b2852818b82f8b83b996cff9685e7fedc407..34e0dd03eada3b68dd0b4531857f93e860cc3aa2 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.22 1998/01/09 10:07:48 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/array-tran.lisp,v 1.23 1998/01/10 05:02:26 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -30,8 +30,8 @@
   
 ;;; EXTRACT-ELEMENT-TYPE  -- internal
 ;;;
-;;; Array access functions return an object from the array, hence it's type
-;;; is going to be the array element type.
+;;; Array access functions return an object from the array, hence it's
+;;; type will be asserted to be array element type.
 ;;;
 (defun extract-element-type (array)
   (let ((type (continuation-type array)))
@@ -39,6 +39,17 @@
 	(array-type-element-type type)
 	*universal-type*)))
 
+;;; EXTRACT-UPGRADED-ELEMENT-TYPE  -- internal
+;;;
+;;; Array access functions return an object from the array, hence it's
+;;; type is going to be the array upgraded element type.
+;;;
+(defun extract-upgraded-element-type (array)
+  (let ((type (continuation-type array)))
+    (if (array-type-p type)
+	(array-type-specialized-element-type type)
+	*universal-type*)))
+
 ;;; ASSERT-NEW-VALUE-TYPE  --  internal
 ;;;
 ;;; The ``new-value'' for array setters must fit in the array, and the
@@ -70,9 +81,13 @@
 
 ;;; AREF  --  derive-type optimizer.
 ;;;
-(defoptimizer (aref derive-type) ((array &rest indices))
+(defoptimizer (aref derive-type) ((array &rest indices) node)
   (assert-array-rank array (length indices))
-  (extract-element-type array))
+  ;; If the node continuation has a single use then assert its type.
+  (let ((cont (node-cont node)))
+    (unless (rest (find-uses cont))
+      (assert-continuation-type cont (extract-element-type array))))
+  (extract-upgraded-element-type array))
 
 ;;; %ASET  --  derive-type optimizer.
 ;;;
@@ -83,7 +98,7 @@
 ;;; DATA-VECTOR-REF  --  derive-type optimizer.
 ;;;
 (defoptimizer (data-vector-ref derive-type) ((array index))
-  (extract-element-type array))
+  (extract-upgraded-element-type array))
 
 ;;; DATA-VECTOR-SET  --  derive-type optimizer.
 ;;;
@@ -114,7 +129,7 @@
 ;;; ROW-MAJOR-AREF  --  derive-type optimizer.
 ;;;
 (defoptimizer (row-major-aref derive-type) ((array index))
-  (extract-element-type array))
+  (extract-upgraded-element-type array))
   
 ;;; %SET-ROW-MAJOR-AREF  --  derive-type optimizer.
 ;;;