Commits

Anonymous committed 08990ae

zero-extending options for bitstring->blob bitstring->u8vector

Comments (0)

Files changed (2)

         initial
         bs))
 
-(define (bitstring->blob bs)
-  ;NOTE: optimize me! 
-  (u8vector->blob (list->u8vector (bitstring->list bs 8))))
+(define (bitstring-size-in-bytes bs)
+  (let ((n (bitstring-length bs)))
+    (+ (quotient n 8) (if (zero? (remainder n 8)) 0 1))))
+
+(define (bitstring->blob bs #!optional (zero-extending 'left))
+  (u8vector->blob/shared (bitstring->u8vector bs zero-extending)))
+
+(define (bitstring->u8vector bs #!optional (zero-extending 'left))
+  (let ((vec (make-u8vector (bitstring-size-in-bytes bs))))
+    (bitstring-fold
+	  (lambda (offset numbits value index)
+	    (if (= numbits 8)
+	      (u8vector-set! vec index value)
+	      (u8vector-set! vec index
+	        (let ((ze-left (arithmetic-shift value (- numbits 8))))
+	      	  (if (eq? zero-extending 'left) 
+	      	    ze-left
+                (arithmetic-shift ze-left (- 8 numbits))))))
+        (+ index 1))
+      0
+      bs)
+    vec))
 
 (define (bitstring->string bs)
   (list->string (map integer->char (bitstring->list bs 8))))
 
-(define (bitstring->u8vector bs)
-  (list->u8vector (bitstring->list bs 8)))
-  
 (define (bitstring->vector bs)
   (list->vector (bitstring->list bs 8)))
 
 (test x (bitstring->vector (vector->bitstring x)))
 (test-end)
 
+(define bs9)
+(define bs7)
+(bitmatch (u8vector #xff #xff)
+  (((a 9 bitstring) (b bitstring))
+    (set! bs9 a)
+    (set! bs7 b)))
+
 (test-begin "bitstring <-> u8vector")
 (define x (u8vector 1 2 3))
 (test x (bitstring->u8vector (u8vector->bitstring x)))
+(define y (u8vector #xff #x01))
+(test y (bitstring->u8vector bs9))
+(define z (u8vector #xff #x80))
+(test z (bitstring->u8vector bs9 'right))
+(define w (u8vector #b01111111))
+(test w (bitstring->u8vector bs7 'left))
+(define g (u8vector #b11111110))
+(test g (bitstring->u8vector bs7 'right))
 (test-end)
 
 (test-begin "bitstring <-> blob")
 (define x '#${1 2 3})
 (test x (bitstring->blob (blob->bitstring x)))
+(define y '#${ff01})
+(test y (bitstring->blob bs9))
+(define z '#${ff80})
+(test z (bitstring->blob bs9 'right))
 (test-end)
 
 (test-begin "bitstring <-> string")