[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv16035

Modified Files:
	arrays.lisp 
Log Message:
Added bit and sbit accessors.


--- /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp	2006/04/07 21:47:44	1.57
+++ /project/movitz/cvsroot/movitz/losp/muerte/arrays.lisp	2006/05/02 20:00:20	1.58
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sun Feb 11 23:14:04 2001
 ;;;;                
-;;;; $Id: arrays.lisp,v 1.57 2006/04/07 21:47:44 ffjeld Exp $
+;;;; $Id: arrays.lisp,v 1.58 2006/05/02 20:00:20 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -620,6 +620,153 @@
 (defun (setf char%unsafe) (value string index)
   (setf (char%unsafe string index) value))
 
+;;; bit accessors
+
+(defun bit (array &rest subscripts)
+  (numargs-case
+   (2 (array index)
+      (etypecase array
+	(indirect-vector
+	 (with-indirect-vector (indirect array :check-type nil)
+	   (aref (indirect displaced-to) (+ index (indirect displaced-offset)))))
+	(simple-bit-vector
+	 (macrolet
+	     ((do-it ()
+		`(with-inline-assembly (:returns :eax)
+		   (:compile-two-forms (:eax :ebx) array index)
+		   (:testb ,movitz:+movitz-fixnum-zmask+ :bl)
+		   (:jnz '(:sub-program (illegal-index)
+			   (:compile-form (:result-mode :ignore)
+			    (error "Illegal index: ~S." index))))
+		   (:cmpl :ebx
+			  (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)))
+		   (:jbe '(:sub-program (out-of-bounds)
+			   (:compile-form (:result-mode :ignore)
+			    (error "Index ~D is beyond vector length ~D."
+			     index
+			     (memref array
+			      (movitz-type-slot-offset 'movitz-basic-vector 'num-elements))))))
+		  :bit
+		   (:movl :ebx :ecx)
+		   (:movl :eax :ebx)
+		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		   (:xorl :eax :eax)
+		   (:btl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
+		   (:jnc 'return)
+		   (:addl ,movitz:+movitz-fixnum-factor+ :eax)
+		  return)))
+	   (do-it)))))
+   (t (vector &rest subscripts)
+      (declare (ignore vector subscripts))
+      (error "Multi-dimensional arrays not implemented."))))
+
+(defun sbit (array &rest subscripts)
+  (numargs-case
+   (2 (array index)
+      (check-type array simple-bit-vector)
+      (macrolet
+	  ((do-it ()
+	     `(with-inline-assembly (:returns :eax)
+		(:compile-two-forms (:eax :ebx) array index)
+		(:testb ,movitz:+movitz-fixnum-zmask+ :bl)
+		(:jnz '(:sub-program (illegal-index)
+			(:compile-form (:result-mode :ignore)
+			 (error "Illegal index: ~S." index))))
+		(:cmpl :ebx
+		       (:eax ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements)))
+		(:jbe '(:sub-program (out-of-bounds)
+			(:compile-form (:result-mode :ignore)
+			 (error "Index ~D is beyond vector length ~D."
+			  index
+			  (memref array
+			   (movitz-type-slot-offset 'movitz-basic-vector 'num-elements))))))
+	       :bit
+		(:movl :ebx :ecx)
+		(:movl :eax :ebx)
+		(:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		(:xorl :eax :eax)
+		(:btl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
+		(:jnc 'return)
+		(:addl ,movitz:+movitz-fixnum-factor+ :eax)
+	       return)))
+	(do-it)))
+   (t (vector &rest subscripts)
+      (declare (ignore vector subscripts))
+      (error "Multi-dimensional arrays not implemented."))))
+
+
+(defun (setf bit) (value vector &rest subscripts)
+  (numargs-case
+   (3 (value vector index)
+      (check-type value bit)
+      (etypecase vector
+	(indirect-vector
+	 (with-indirect-vector (indirect vector :check-type nil)
+	   (setf (aref (indirect displaced-to) (+ index (indirect displaced-offset)))
+	     value)))
+	(simple-bit-vector
+	 (macrolet
+	     ((do-it ()
+		`(with-inline-assembly (:returns :eax)
+		   (:compile-two-forms (:eax :ebx) value vector)
+		   (:compile-form (:result-mode :edx) index)
+		   (:testb ,movitz:+movitz-fixnum-zmask+ :dl)
+		   (:jnz '(:sub-program (not-an-index)
+			   (:compile-form (:result-mode :ignore)
+			    (error "Not a vector index: ~S." index))))
+		   (:cmpl (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+			  :edx)
+		   (:jnc '(:sub-program (illegal-index)
+			   (:compile-form (:result-mode :ignore)
+			    (error "Index ~S out of range." index))))
+		   (:movl :edx :ecx)
+		   (:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		   
+		   (:testl :eax :eax)
+		   (:jnz 'set-one-bit)
+		   (:btrl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
+		   (:jmp 'return)
+		  set-one-bit
+		   (:btsl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
+		  return)))
+	   (do-it)))))
+   (t (value vector &rest subscripts)
+      (declare (ignore value vector subscripts))
+      (error "Multi-dimensional arrays not implemented."))))
+
+(defun (setf sbit) (value vector &rest subscripts)
+  (numargs-case
+   (3 (value vector index)
+      (check-type value bit)
+      (macrolet
+	  ((do-it ()
+	     `(with-inline-assembly (:returns :eax)
+		(:compile-two-forms (:eax :ebx) value vector)
+		(:compile-form (:result-mode :edx) index)
+		(:testb ,movitz:+movitz-fixnum-zmask+ :dl)
+		(:jnz '(:sub-program (not-an-index)
+			(:compile-form (:result-mode :ignore)
+			 (error "Not a vector index: ~S." index))))
+		(:cmpl (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::num-elements))
+		       :edx)
+		(:jnc '(:sub-program (illegal-index)
+			(:compile-form (:result-mode :ignore)
+			 (error "Index ~S out of range." index))))
+		(:movl :edx :ecx)
+		(:shrl ,movitz:+movitz-fixnum-shift+ :ecx)
+		   
+		(:testl :eax :eax)
+		(:jnz 'set-one-bit)
+		(:btrl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
+		(:jmp 'return)
+	       set-one-bit
+		(:btsl :ecx (:ebx ,(bt:slot-offset 'movitz:movitz-basic-vector 'movitz::data)))
+	       return)))
+	(do-it)))
+   (t (value vector &rest subscripts)
+      (declare (ignore value vector subscripts))
+      (error "Multi-dimensional arrays not implemented."))))
+
 ;;; u8 accessors
 
 (define-compiler-macro u8ref%unsafe (vector index)