From dbde187c3afc2919418ac34ca9fab92979ae64a1 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Wed, 21 Mar 1990 23:36:16 +0000
Subject: [PATCH] Added deftransforms for various kinds of
 data-vector-{ref,sef}.

---
 compiler/generic/vm-tran.lisp | 74 ++++++++++++++++++++++++++++++++++-
 1 file changed, 73 insertions(+), 1 deletion(-)

diff --git a/compiler/generic/vm-tran.lisp b/compiler/generic/vm-tran.lisp
index 851fea540..acf870eb5 100644
--- a/compiler/generic/vm-tran.lisp
+++ b/compiler/generic/vm-tran.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.3 1990/03/08 21:39:31 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.4 1990/03/21 23:36:16 wlott Exp $
 ;;;
 ;;;    This file contains impelemtentation-dependent transforms.
 ;;;
@@ -71,3 +71,75 @@
 (def-primitive-translator header-length (obj)
   (warn "Someone used HEADER-LENGTH.")
   `(%primitive vector-length ,obj))
+
+
+
+;;; Transforms for data-vector-ref for strange array types.
+
+
+(deftransform data-vector-ref ((array index)
+			       (simple-array t))
+  (let ((array-type (continuation-type array)))
+    (unless (array-type-p array-type)
+      (give-up))
+    (let ((dims (array-type-dimensions array-type)))
+      (when (or (atom dims) (= (length dims) 1))
+	(give-up))
+      (let ((el-type (array-type-element-type array-type))
+	    (total-size (if (member '* dims)
+			    '*
+			    (reduce #'* dims))))
+	`(data-vector-ref (truly-the (simple-array ,(type-specifier el-type)
+						   (,total-size))
+				     (%array-data-vector array))
+			  index)))))
+
+(deftransform data-vector-set ((array index new-value)
+			       (simple-array t t))
+  (let ((array-type (continuation-type array)))
+    (unless (array-type-p array-type)
+      (give-up))
+    (let ((dims (array-type-dimensions array-type)))
+      (when (or (atom dims) (= (length dims) 1))
+	(give-up))
+      (let ((el-type (array-type-element-type array-type))
+	    (total-size (if (member '* dims)
+			    '*
+			    (reduce #'* dims))))
+	`(data-vector-ref (truly-the (simple-array ,(type-specifier el-type)
+						   (,total-size))
+				     (%array-data-vector array))
+			  index
+			  new-value)))))
+
+
+;;; Transforms for getting at arrays of unsigned-byte n when n < 8.
+
+#+nil
+(macrolet
+    ((frob (type bits)
+       `(progn
+	  (deftransform data-vector-ref ((vector index)
+					 (,type *))
+	    `(multiple-value-bind (word bit)
+				  (floor index ,(truncate 16 ,bits))
+	       (ldb ,(ecase vm:target-byte-order
+		       (:little-endian '(byte ,bits bit))
+		       (:big-endian '(byte 1 (- 16 ,bits bit))))
+		    (%raw-bits vector (+ (* word 16)
+					 (* vm:vector-data-offset
+					    vm:word-bits))))))
+	  (deftransform data-vector-set ((vector index new-value)
+					 (,type * *))
+	    `(multiple-value-bind (word bit)
+				  (floor index ,(truncate 16 ,bits))
+	       (setf (ldb ,(ecase vm:target-byte-order
+			     (:little-endian '(byte ,bits bit))
+			     (:big-endian '(byte 1 (- 16 ,bits bit))))
+			  (%raw-bits vector (+ (* word 16)
+					       (* vm:vector-data-offset
+						  vm:word-bits))))
+		     new-value))))))
+  (frob simple-bit-vector 1)
+  (frob (simple-array (unsigned-byte 2) (*)) 2)
+  (frob (simple-array (unsigned-byte 4) (*)) 4))
-- 
GitLab