* Added bytevector->u8-list, u8-list->bytevector, and

bytevector-copy!.

src/ikarus.bytevectors.ss

@@ -1,12 +1,15 @@
 
 (library (ikarus bytevectors)
   (export make-bytevector bytevector-length bytevector-s8-ref
-          bytevector-u8-ref bytevector-u8-set! bytevector-s8-set!)
+          bytevector-u8-ref bytevector-u8-set! bytevector-s8-set!
+          bytevector-copy! u8-list->bytevector bytevector->u8-list)
   (import 
     (except (ikarus) 
         make-bytevector bytevector-length bytevector-s8-ref
-        bytevector-u8-ref bytevector-u8-set! bytevector-s8-set!)
+        bytevector-u8-ref bytevector-u8-set! bytevector-s8-set! 
+        bytevector-copy! u8-list->bytevector bytevector->u8-list)
     (ikarus system $fx)
+    (ikarus system $pairs)
     (ikarus system $bytevectors))
 
   (define ($bytevector-fill x i j fill)
@@ -70,6 +73,88 @@
               (error 'bytevector-u8-set! "invalid index ~s for ~s" i x))
           (error 'bytevector-u8-set! "~s is not a bytevector" x))))
   
+  (define bytevector->u8-list
+    (lambda (x)
+      (unless (bytevector? x)
+        (error 'bytevector->u8-list "~s is not a bytevector" x))
+      (let f ([x x] [i ($bytevector-length x)] [ac '()])
+        (cond
+          [($fx= i 0) ac]
+          [else
+           (let ([i ($fxsub1 i)])
+             (f x i (cons ($bytevector-u8-ref x i) ac)))]))))
+
+  (define u8-list->bytevector
+    (letrec ([race
+              (lambda (h t ls n)
+               (if (pair? h)
+                   (let ([h ($cdr h)])
+                      (if (pair? h)
+                          (if (not (eq? h t))
+                              (race ($cdr h) ($cdr t) ls ($fx+ n 2))
+                              (error 'u8-list->bytevector "circular list ~s" ls))
+                          (if (null? h)
+                              ($fx+ n 1)
+                              (error 'u8-list->bytevector "~s is not a proper list" ls))))
+                   (if (null? h)
+                       n
+                       (error 'u8-list->bytevector "~s is not a proper list" ls))))]
+              [fill
+               (lambda (s i ls)
+                 (cond
+                   [(null? ls) s]
+                   [else
+                    (let ([c ($car ls)])
+                      (unless (and (fixnum? c) ($fx<= 0 c) ($fx<= c 255))
+                        (error 'u8-list->bytevector "~s is not an octet" c))
+                      ($bytevector-set! s i c)
+                      (fill s ($fxadd1 i) (cdr ls)))]))])
+       (lambda (ls)
+         (let ([n (race ls ls ls 0)])
+           (let ([s ($make-bytevector n)])
+             (fill s 0 ls))))))
+
+  (define bytevector-copy!
+    (lambda (src src-start dst dst-start k) 
+      (cond
+        [(or (not (fixnum? src-start)) ($fx< src-start 0))
+         (error 'bytevector-copy! "~s is not a valid starting index" src-start)]
+        [(or (not (fixnum? dst-start)) ($fx< dst-start 0))
+         (error 'bytevector-copy! "~s is not a valid starting index" dst-start)]
+        [(or (not (fixnum? k)) ($fx< k 0))
+         (error 'bytevector-copy! "~s is not a valid length" k)]
+        [(not (bytevector? src)) 
+         (error 'bytevector-copy! "~s is not a bytevector" src)]
+        [(not (bytevector? dst)) 
+         (error 'bytevector-copy! "~s is not a bytevector" dst)]
+        [(let ([n ($fx+ src-start k)])
+           (or ($fx< n 0) ($fx>= n ($bytevector-length src))))
+         (error 'bytevector-copy! "~s+~s is out of range" src-start k)]
+        [(let ([n ($fx+ dst-start k)])
+           (or ($fx< n 0) ($fx>= n ($bytevector-length dst))))
+         (error 'bytevector-copy! "~s+~s is out of range" dst-start k)]
+        [(eq? src dst)
+         (cond
+           [($fx< dst-start src-start)
+            (let f ([src src] [si src-start] [di dst-start] [sj ($fx+ src-start k)])
+              (unless ($fx= si sj)
+                ($bytevector-set! src di ($bytevector-u8-ref src si))
+                (f src ($fxadd1 si) ($fxadd1 di) sj)))]
+           [($fx< src-start dst-start)
+            (let f ([src src] [si ($fx+ src-start k)] [di ($fx+ dst-start k)] [sj src-start])
+              (unless ($fx= si sj)
+                (let ([si ($fxsub1 si)] [di ($fxsub1 di)])
+                  ($bytevector-set! src di ($bytevector-u8-ref src si))
+                  (f src si di sj))))]
+           [else (void)])]
+        [else
+         (let f ([src src] [si src-start] [dst dst] [di dst-start] [sj ($fx+ src-start k)])
+           (unless ($fx= si sj)
+             ($bytevector-set! dst di ($bytevector-u8-ref src si))
+             (f src ($fxadd1 si) dst ($fxadd1 di) sj)))])))
+
+
+
   )
 
 

src/makefile.ss

@@ -277,6 +277,9 @@
     [bytevector-u8-ref       i]
     [bytevector-s8-set!      i]
     [bytevector-u8-set!      i]
+    [bytevector->u8-list     i]
+    [u8-list->bytevector     i]
+    [bytevector-copy!        i]
 
     [for-each                i r]
     [map                     i r]

src/tests/bytevectors.ss

@@ -35,6 +35,11 @@
          (bytevector-s8-ref b 1)
          (bytevector-u8-ref b 1)))]
 
+    [(lambda (x) (equal? x '(1 2 3 1 2 3 4 8)))
+     (let ([b (u8-list->bytevector '(1 2 3 4 5 6 7 8))])
+       (bytevector-copy! b 0 b 3 4)
+       (bytevector->u8-list b))]
+
     ))