[movitz-cvs] CVS movitz

[ffjeld]

Update of /project/movitz/cvsroot/movitz
In directory clnet:/tmp/cvs-serv14395

Modified Files:
	storage-types.lisp 
Log Message:
Support dumping of bit-vectors.


--- /project/movitz/cvsroot/movitz/storage-types.lisp	2008/03/20 22:24:27	1.61
+++ /project/movitz/cvsroot/movitz/storage-types.lisp	2008/03/23 12:19:19	1.62
@@ -9,7 +9,7 @@
 ;;;; Created at:    Sun Oct 22 00:22:43 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: storage-types.lisp,v 1.61 2008/03/20 22:24:27 ffjeld Exp $
+;;;; $Id: storage-types.lisp,v 1.62 2008/03/23 12:19:19 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -417,15 +417,26 @@
 	     (:character (write-binary 'char8 stream data))
 	     (:any-t     (write-binary 'word stream (movitz-read-and-intern data 'word))))))
     (+ (call-next-method)		; header
-       (etypecase (movitz-vector-symbolic-data obj)
-	 (list 
-	  (loop for data in (movitz-vector-symbolic-data obj)
-	      with type = (movitz-vector-element-type obj)
-	      summing (write-element type stream data)))
-	 (vector
-	  (loop for data across (movitz-vector-symbolic-data obj)
-	      with type = (movitz-vector-element-type obj)
-	      summing (write-element type stream data)))))))
+       (multiple-value-bind (data type)
+	   (case (movitz-vector-element-type obj)
+	     (:bit (let ((data (movitz-vector-symbolic-data obj)))
+		     (values (loop for byte upfrom 0 below (ceiling (length data) 8)
+				collect (loop for bit from 0 to 7
+					   sum (* (let ((b (+ (* byte 8) bit)))
+						    (if (< b (length data))
+							(bit data b)
+							0))
+						  (expt 2 bit))))
+			     :u8)))
+	     (t (values (movitz-vector-symbolic-data obj)
+			(movitz-vector-element-type obj))))
+	 (etypecase data
+	   (list 
+	    (loop for datum in data
+	       sum (write-element type stream datum)))
+	   (vector
+	    (loop for datum across data
+	       sum (write-element type stream datum))))))))
 
 (defmethod read-binary-record ((type-name (eql 'movitz-basic-vector)) stream &key &allow-other-keys)
   (let ((object (call-next-method)))
@@ -452,6 +463,8 @@
   (cond
    ((eq type 'code)
     (values :code 0))
+   ((subtypep type 'bit)
+    (values :bit 0))
    ((subtypep type '(unsigned-byte 8))
     (values :u8 0))
    ((subtypep type '(unsigned-byte 16))
@@ -502,7 +515,7 @@
       (setf initial-contents
 	(make-array size :initial-element (or (and initial-element-p initial-element)
 					      default-element))))
-    (assert (member et '(:any-t :character :u8 :u32 :code)))
+    (assert (member et '(:any-t :bit :character :u8 :u32 :code)))
     (when flags (break "flags: ~S" flags))
     (when (and alignment-offset (plusp alignment-offset))
       (break "alignment: ~S" alignment-offset))