diff --git a/compiler/x86/arith.lisp b/compiler/x86/arith.lisp
index cebeffedefbce0fe502f731c97f49b4accd37587..dee98268e8136c9fc31966de7332cc9bb728621d 100644
--- a/compiler/x86/arith.lisp
+++ b/compiler/x86/arith.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/arith.lisp,v 1.1 1997/01/18 14:31:24 ram Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/arith.lisp,v 1.2 1997/02/05 15:34:11 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -779,18 +779,20 @@
 (def-source-transform 32bit-logical-andc2 (x y)
   `(32bit-logical-and ,x (32bit-logical-not ,y)))
 
+;;; Only the lower 5 bits of the shift amount are significant.
 
 (define-vop (shift-towards-someplace)
   (:policy :fast-safe)
   (:args (num :scs (unsigned-reg) :target r)
-	 (amount :scs (unsigned-reg signed-reg) :target ecx))
-  (:arg-types unsigned-num positive-fixnum)
+	 (amount :scs (signed-reg) :target ecx))
+  (:arg-types unsigned-num tagged-num)
   (:temporary (:sc dword-reg :offset ecx-offset :from (:argument 1)) ecx)
-  (:results (r :scs (unsigned-reg)))
+  (:results (r :scs (unsigned-reg) :from (:argument 0)))
   (:result-types unsigned-num))
 
 (define-vop (shift-towards-start shift-towards-someplace)
   (:translate shift-towards-start)
+  (:note "SHIFT-TOWARDS-START")
   (:generator 1
     (move r num)
     (move ecx amount)
@@ -798,12 +800,12 @@
 
 (define-vop (shift-towards-end shift-towards-someplace)
   (:translate shift-towards-end)
+  (:note "SHIFT-TOWARDS-END")
   (:generator 1
     (move r num)
     (move ecx amount)
     (inst shl r :cl)))
 
-
 
 ;;;; Bignum stuff.
 
diff --git a/compiler/x86/array.lisp b/compiler/x86/array.lisp
index f5f957a9610ec69801fb64ea1b94d20eb48e2d95..b05ec2624799f2a0cf1d58dc14754ae7045f5fd7 100644
--- a/compiler/x86/array.lisp
+++ b/compiler/x86/array.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
- "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/array.lisp,v 1.1 1997/01/18 14:31:24 ram Exp $")
+ "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/x86/array.lisp,v 1.2 1997/02/05 15:34:13 pw Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -16,6 +16,7 @@
 ;;; Written by William Lott
 ;;;
 ;;; Debugged by Paul F. Werkowski Spring/Summer 1995.
+;;; Enhancements/debugging by Douglas T. Crosher 1996,1997.
 ;;;
 (in-package :x86)
 
@@ -296,6 +297,22 @@
 			:disp (- (* vm:vector-data-offset vm:word-bytes)
 				 vm:other-pointer-type))))))
 
+(define-vop (data-vector-ref-c/simple-array-single-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-single-float (:constant (signed-byte 30)))
+  (:results (value :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 4
+   (with-empty-tn@fp-top(value)
+     (inst fld (make-ea	:dword :base object
+			:disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				    (* 4 index))
+				 vm:other-pointer-type))))))
+
 (define-vop (data-vector-set/simple-array-single-float)
   (:note "inline array store")
   (:translate data-vector-set)
@@ -307,29 +324,67 @@
   (:results (result :scs (single-reg)))
   (:result-types single-float)
   (:generator 5
-    (if (zerop (tn-offset value))
-	(progn
-	  ;; Value is in ST0
-	  (inst fst (make-ea :dword :base object :index index :scale 1
-			     :disp (- (* vm:vector-data-offset vm:word-bytes)
-				      vm:other-pointer-type)))
-	  (unless (zerop (tn-offset result))
-	      ;; Value is in ST0 but not result.
-	      (inst fst result)))
-      (progn
-	;; Value is not in ST0.
-	(inst fxch value)
-	(inst fst (make-ea :dword :base object :index index :scale 1
-			   :disp (- (* vm:vector-data-offset vm:word-bytes)
-				    vm:other-pointer-type)))
-	(if (zerop (tn-offset result))
-	    ;; The result is in ST0.
-	    (inst fst value)
-	  (progn
-	    ;; Neither value or result are in ST0
-	    (unless (location= value result)
-		  (inst fst result))
-	    (inst fxch value)))))))
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (inst fst (make-ea :dword :base object :index index :scale 1
+			      :disp (- (* vm:vector-data-offset vm:word-bytes)
+				       vm:other-pointer-type)))
+	   (unless (zerop (tn-offset result))
+		   ;; Value is in ST0 but not result.
+		   (inst fst result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (inst fst (make-ea :dword :base object :index index :scale 1
+			      :disp (- (* vm:vector-data-offset vm:word-bytes)
+				       vm:other-pointer-type)))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fst value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+			  (inst fst result))
+		  (inst fxch value)))))))
+
+(define-vop (data-vector-set-c/simple-array-single-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (single-reg) :target result))
+  (:info index)
+  (:arg-types simple-array-single-float (:constant (signed-byte 30))
+	      single-float)
+  (:results (result :scs (single-reg)))
+  (:result-types single-float)
+  (:generator 4
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (inst fst (make-ea :dword :base object
+			      :disp (- (+ (* vm:vector-data-offset
+					     vm:word-bytes)
+					  (* 4 index))
+				       vm:other-pointer-type)))
+	   (unless (zerop (tn-offset result))
+		   ;; Value is in ST0 but not result.
+		   (inst fst result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (inst fst (make-ea :dword :base object
+			      :disp (- (+ (* vm:vector-data-offset
+					     vm:word-bytes)
+					  (* 4 index))
+				       vm:other-pointer-type)))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fst value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+			  (inst fst result))
+		  (inst fxch value)))))))
 
 (define-vop (data-vector-ref/simple-array-double-float)
   (:note "inline array access")
@@ -346,6 +401,22 @@
 			 :disp (- (* vm:vector-data-offset vm:word-bytes)
 				  vm:other-pointer-type))))))
 
+(define-vop (data-vector-ref-c/simple-array-double-float)
+  (:note "inline array access")
+  (:translate data-vector-ref)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg)))
+  (:info index)
+  (:arg-types simple-array-double-float (:constant (signed-byte 30)))
+  (:results (value :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 6
+   (with-empty-tn@fp-top(value)
+     (inst fldd (make-ea :dword :base object
+			 :disp (- (+ (* vm:vector-data-offset vm:word-bytes)
+				     (* 8 index))
+				  vm:other-pointer-type))))))
+
 (define-vop (data-vector-set/simple-array-double-float)
   (:note "inline array store")
   (:translate data-vector-set)
@@ -357,49 +428,102 @@
   (:results (result :scs (double-reg)))
   (:result-types double-float)
   (:generator 20
-    (if (zerop (tn-offset value))
-	(progn
-	  ;; Value is in ST0
-	  (inst fstd (make-ea :dword :base object :index index :scale 2
-			      :disp (- (* vm:vector-data-offset vm:word-bytes)
-				       vm:other-pointer-type)))
-	  (unless (zerop (tn-offset result))
-	      ;; Value is in ST0 but not result.
-	      (inst fstd result)))
-      (progn
-	;; Value is not in ST0.
-	(inst fxch value)
-	(inst fstd (make-ea :dword :base object :index index :scale 2
-			    :disp (- (* vm:vector-data-offset vm:word-bytes)
-				     vm:other-pointer-type)))
-	(if (zerop (tn-offset result))
-	    ;; The result is in ST0.
-	    (inst fstd value)
-	  (progn
-	    ;; Neither value or result are in ST0
-	    (unless (location= value result)
-		  (inst fstd result))
-	    (inst fxch value)))))))
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (inst fstd (make-ea :dword :base object :index index :scale 2
+			       :disp (- (* vm:vector-data-offset vm:word-bytes)
+					vm:other-pointer-type)))
+	   (unless (zerop (tn-offset result))
+		   ;; Value is in ST0 but not result.
+		   (inst fstd result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (inst fstd (make-ea :dword :base object :index index :scale 2
+			       :disp (- (* vm:vector-data-offset vm:word-bytes)
+					vm:other-pointer-type)))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fstd value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+			  (inst fstd result))
+		  (inst fxch value)))))))
+
+
+(define-vop (data-vector-set-c/simple-array-double-float)
+  (:note "inline array store")
+  (:translate data-vector-set)
+  (:policy :fast-safe)
+  (:args (object :scs (descriptor-reg))
+	 (value :scs (double-reg) :target result))
+  (:info index)
+  (:arg-types simple-array-double-float (:constant (signed-byte 30))
+	      double-float)
+  (:results (result :scs (double-reg)))
+  (:result-types double-float)
+  (:generator 19
+    (cond ((zerop (tn-offset value))
+	   ;; Value is in ST0
+	   (inst fstd (make-ea :dword :base object
+			       :disp (- (+ (* vm:vector-data-offset
+					      vm:word-bytes)
+					   (* 8 index))
+					vm:other-pointer-type)))
+	   (unless (zerop (tn-offset result))
+		   ;; Value is in ST0 but not result.
+		   (inst fstd result)))
+	  (t
+	   ;; Value is not in ST0.
+	   (inst fxch value)
+	   (inst fstd (make-ea :dword :base object
+			       :disp (- (+ (* vm:vector-data-offset
+					      vm:word-bytes)
+					   (* 8 index))
+					vm:other-pointer-type)))
+	   (cond ((zerop (tn-offset result))
+		  ;; The result is in ST0.
+		  (inst fstd value))
+		 (t
+		  ;; Neither value or result are in ST0
+		  (unless (location= value result)
+			  (inst fstd result))
+		  (inst fxch value)))))))
+
 
 ;;; These VOPs are used for implementing float slots in structures (whose raw
 ;;; data is an unsigned-32 vector.
-;;; pfw-copied from hppa
-
+;;;
 (define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
   (:translate %raw-ref-single)
   (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+(define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float)
+  (:translate %raw-ref-single)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
 ;;;
 (define-vop (raw-set-single data-vector-set/simple-array-single-float)
   (:translate %raw-set-single)
   (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
+(define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float)
+  (:translate %raw-set-single)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
+	      single-float))
 ;;;
 (define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
   (:translate %raw-ref-double)
   (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+(define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float)
+  (:translate %raw-ref-double)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
 ;;;
 (define-vop (raw-set-double data-vector-set/simple-array-double-float)
   (:translate %raw-set-double)
   (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
+(define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
+  (:translate %raw-set-double)
+  (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
+	      double-float))
 
 
 ;;; These vops are useful for accessing the bits of a vector irrespective of
@@ -483,7 +607,8 @@
 	 (value :scs (unsigned-reg unsigned-stack signed-reg signed-stack)
 		:target eax))
   (:info index)
-  (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30)) positive-fixnum)
+  (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30))
+	      positive-fixnum)
   (:temporary (:sc dword-reg :offset eax-offset :target result
 		   :from (:argument 1) :to (:result 0))
 	      eax)