Changeset 16152 in project


Ignore:
Timestamp:
10/08/09 06:49:54 (10 years ago)
Author:
Ivan Raikov
Message:

added srfi-4 conversion procedures to byte-blob

Location:
release/4/byte-blob/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/byte-blob/trunk/byte-blob.scm

    r16144 r16152  
    4343         byte-blob-empty
    4444         list->byte-blob
     45         string->byte-blob
    4546         byte-blob-replicate
    4647         byte-blob-object
     
    6263         byte-blob-read
    6364         byte-blob-write
     65
     66         u8vector->byte-blob 
     67         s8vector->byte-blob 
     68         u16vector->byte-blob
     69         s16vector->byte-blob
     70         u32vector->byte-blob
     71         s32vector->byte-blob
     72         f32vector->byte-blob
     73         f64vector->byte-blob
     74         byte-blob->u8vector 
     75         byte-blob->s8vector 
     76         byte-blob->u16vector
     77         byte-blob->s16vector
     78         byte-blob->u32vector
     79         byte-blob->s32vector
     80         byte-blob->f32vector
     81         byte-blob->f64vector
    6482         )
    6583
     
    118136   
    119137
     138(define (string->byte-blob str)
     139  (make-byte-blob (string->blob str) 0))
    120140
    121141(define blob-fill
     
    234254
    235255(define (byte-blob-drop b n)
    236   (let ((blen   (byte-blob-size b)))
    237     (assert (and (positive? n) (< n blen)))
    238     (byte-blob-copy b (+ n (byte-blob-offset b)))))
     256  (if (zero? n) b
     257      (let ((blen   (byte-blob-size b)))
     258        (assert (and (positive? n) (< n blen)))
     259        (byte-blob-copy b (+ n (byte-blob-offset b))))))
    239260
    240261
    241262(define (byte-blob-span b start end)
    242   (assert (and (positive? start) (positive? end) (< start end)))
     263  (assert (and (or (zero? start) (positive? start)) (positive? end) (< start end)))
    243264  (byte-blob-take (byte-blob-drop b start) (- end start)))
    244265
     
    377398
    378399
     400;; code borrowed from srfi-4.scm:
     401
     402(define (pack-copy tag loc)
     403  (lambda (v)
     404    (##sys#check-structure v tag loc)
     405    (let* ((old (##sys#slot v 1))
     406           (new (##sys#make-blob (##sys#size old))))
     407      (##core#inline "C_copy_block" old new)
     408      (make-byte-blob new 0)
     409      )))
     410
     411(define u8vector->byte-blob (pack-copy 'u8vector 'u8vector->byte-blob))
     412(define s8vector->byte-blob (pack-copy 's8vector 's8vector->byte-blob))
     413(define u16vector->byte-blob (pack-copy 'u16vector 'u16vector->byte-blob))
     414(define s16vector->byte-blob (pack-copy 's16vector 's16vector->byte-blob))
     415(define u32vector->byte-blob (pack-copy 'u32vector 'u32vector->byte-blob))
     416(define s32vector->byte-blob (pack-copy 's32vector 's32vector->byte-blob))
     417(define f32vector->byte-blob (pack-copy 'f32vector 'f32vector->byte-blob))
     418(define f64vector->byte-blob (pack-copy 'f64vector 'f64vector->byte-blob))
     419
     420
     421(define (unpack-copy tag sz loc)
     422  (lambda (bb)
     423    (let ((str (byte-blob-object bb))
     424          (offset (byte-blob-offset bb)))
     425      (##sys#check-byte-vector str loc)
     426      (let* ((len (byte-blob-size bb))
     427             (new (##sys#make-blob len)))
     428        (if (or (eq? #t sz)
     429                (eq? 0 (##core#inline "C_fixnum_modulo" len sz)))
     430            (begin
     431              (move-memory! str new len offset)
     432              (##sys#make-structure
     433               tag new))
     434            (##sys#error loc "blob does not have correct size for packing" tag len sz) ) ) ) ))
     435
     436
     437(define byte-blob->u8vector (unpack-copy 'u8vector #t 'byte-blob->u8vector))
     438(define byte-blob->s8vector (unpack-copy 's8vector #t 'byte-blob->s8vector))
     439(define byte-blob->u16vector (unpack-copy 'u16vector 2 'byte-blob->u16vector))
     440(define byte-blob->s16vector (unpack-copy 's16vector 2 'byte-blob->s16vector))
     441(define byte-blob->u32vector (unpack-copy 'u32vector 4 'byte-blob->u32vector))
     442(define byte-blob->s32vector (unpack-copy 's32vector 4 'byte-blob->s32vector))
     443(define byte-blob->f32vector (unpack-copy 'f32vector 4 'byte-blob->f32vector))
     444(define byte-blob->f64vector (unpack-copy 'f64vector 8 'byte-blob->f64vector))
     445
     446
    379447
    380448)
  • release/4/byte-blob/trunk/tests/run.scm

    r16144 r16152  
    11
    2 (use byte-blob test posix)
     2(use byte-blob test posix srfi-4)
    33
    44
     
    1111
    1212(test-group "byte-blob test"
     13
     14            (test (sprintf "f32vector <-> byte-blob")
     15                  (f32vector 1.02 3.04 5.06)
     16                  (byte-blob->f32vector (f32vector->byte-blob (f32vector 1.02 3.04 5.06))))
    1317
    1418            (test (sprintf "byte-blob-replicate")
Note: See TracChangeset for help on using the changeset viewer.