source: project/release/4/byte-blob/trunk/byte-blob.scm @ 16152

Last change on this file since 16152 was 16152, checked in by Ivan Raikov, 10 years ago

added srfi-4 conversion procedures to byte-blob

File size: 12.1 KB
Line 
1;;
2;;  Utility procedures for manipulating blobs as byte sequences.
3;;
4;;  Copyright 2009 Ivan Raikov.
5;;
6;;
7;;  Redistribution and use in source and binary forms, with or without
8;;  modification, are permitted provided that the following conditions
9;;  are met:
10;;
11;;  - Redistributions of source code must retain the above copyright
12;;  notice, this list of conditions and the following disclaimer.
13;;
14;;  - Redistributions in binary form must reproduce the above
15;;  copyright notice, this list of conditions and the following
16;;  disclaimer in the documentation and/or other materials provided
17;;  with the distribution.
18;;
19;;  - Neither name of the copyright holders nor the names of its
20;;  contributors may be used to endorse or promote products derived
21;;  from this software without specific prior written permission.
22;;
23;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
24;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
25;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
26;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
27;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
28;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
29;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
30;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
31;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
32;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
33;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
34;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
35;;  POSSIBILITY OF SUCH DAMAGE.
36;;
37
38(module byte-blob
39
40        (byte-blob?
41         byte-blob-empty?
42         byte-blob-size
43         byte-blob-empty
44         list->byte-blob
45         string->byte-blob
46         byte-blob-replicate
47         byte-blob-object
48         byte-blob-offset
49         byte-blob-cons 
50         byte-blob-car
51         byte-blob-cdr
52         byte-blob-append
53         byte-blob-reverse
54         byte-blob-intersperse
55         byte-blob-take
56         byte-blob-drop
57         byte-blob-span
58         byte-blob-map
59         byte-blob-fold-left
60         byte-blob-fold-right
61         byte-blob->list
62         byte-blob->string
63         byte-blob-read
64         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 
82         )
83
84        (import scheme chicken foreign posix)
85
86        (require-extension srfi-1 lolevel )
87
88
89(define-record-type byte-blob
90  (make-byte-blob object offset )
91  byte-blob?
92  (object       byte-blob-object )
93  (offset       byte-blob-offset )
94  )
95
96(define byte-blob->blob byte-blob-object)
97
98(define (byte-blob-size b)
99  (- (blob-size (byte-blob-object b)) 
100     (byte-blob-offset b)))
101
102(define (byte-blob-empty)
103  (make-byte-blob (make-blob 0) 0))
104
105(define (byte-blob-empty? b)
106  (zero? (byte-blob-size b)))
107
108(define (byte-blob-copy b . rest)
109  (let-optionals rest ((offset (byte-blob-offset b)))
110    (assert (or (positive? offset) (zero? offset)))
111    (make-byte-blob (byte-blob-object b) offset )))
112
113(define blob-set! 
114    (foreign-lambda* void ((nonnull-blob b) (integer offset) (byte value))
115#<<END
116   b[offset] = value;
117END
118))
119
120(define blob-ref 
121    (foreign-lambda* byte ((nonnull-blob b) (integer offset))
122#<<END
123   C_word result;
124   result = b[offset];
125   C_return (result);
126END
127))
128
129(define (list->byte-blob lst)
130  (let* ((len (length lst))
131         (ob  (make-blob len)))
132    (let loop ((lst lst) (i 0))
133      (if (null? lst) (make-byte-blob ob 0)
134          (begin (blob-set! ob i (car lst))
135                 (loop (cdr lst) (+ i 1)))))))
136   
137
138(define (string->byte-blob str)
139  (make-byte-blob (string->blob str) 0))
140
141(define blob-fill 
142    (foreign-lambda* void ((nonnull-blob b) (unsigned-int n) (integer offset) (byte value))
143#<<END
144   memset((void *)(b+offset),value,n);
145END
146))
147
148(define (byte-blob-replicate n v)
149  (assert (positive? n))
150  (let* ((ob (make-blob n))
151         (bb (make-byte-blob ob 0)))
152    (blob-fill ob n 0 v)
153    bb))
154
155;; 'blob-cons' is analogous to list cons, but of different complexity,
156;; as it requires a memcpy.
157
158(define (byte-blob-cons x b)
159  (let* ((blen  (byte-blob-size b))
160         (b1len (+ 1 blen))
161         (b1    (make-blob b1len)))
162    (blob-set! b1 0 x)
163    (if (positive? blen) 
164        (move-memory! (byte-blob-object b) b1 blen (byte-blob-offset b) 1))
165    (make-byte-blob b1 0)))
166
167(define (byte-blob-car b)
168  (assert (positive? (byte-blob-size b)))
169  (blob-car (byte-blob-object b) (byte-blob-offset b)))
170
171(define blob-car 
172    (foreign-primitive byte ((nonnull-blob b) (integer offset))
173#<<END
174   C_word result;
175   result = b[offset];
176   C_return (result);
177END
178))
179
180(define (byte-blob-cdr b)
181  (assert (positive? (byte-blob-size b)))
182  (byte-blob-copy b (+ 1 (byte-blob-offset b))))
183
184(define (byte-blob-append a . rst)
185  (if (null? rst) a
186      (let* ((rlen  (map byte-blob-size (cons a rst)))
187             (clen  (fold fx+ 0 rlen))
188             (c     (make-blob clen)))
189        (let loop ((pos 0) (lst (cons a rst)) (len rlen))
190          (if (null? lst) (make-byte-blob c 0)
191              (let ((x (car lst))
192                    (xlen (car len)))
193                (move-memory! (byte-blob-object x) c xlen (byte-blob-offset x) pos)
194                (loop (fx+ pos xlen) (cdr lst) (cdr len)))))
195        )))
196
197   
198
199(define blob-reverse 
200    (foreign-lambda* void ((nonnull-blob b) (nonnull-blob b1) (integer offset) (integer size))
201#<<END
202   int i,p;
203   for (i=offset,p=size-1; p>=0; i++,p--)
204   {
205      b1[p] = b[i];
206   }
207
208   C_return (C_SCHEME_UNDEFINED);
209END
210))
211
212(define (byte-blob-reverse b)
213  (let* ((blen   (byte-blob-size b))
214         (ob     (byte-blob-object b))
215         (ob1    (make-blob blen)))
216    (blob-reverse ob ob1 (byte-blob-offset b) blen)
217    (make-byte-blob ob1 0)))
218
219
220(define blob-intersperse 
221    (foreign-lambda* void ((nonnull-blob b) (nonnull-blob b1) (byte sep) (integer offset) (integer size))
222#<<END
223   int i,p,n;
224   b1[0]=b[offset];
225   for (i=offset+1,p=1,n=size-1; n>0; i++,p+=2,n--)
226   {
227      b1[p] = sep;
228      b1[p+1] = b[i];
229   }
230
231   C_return (C_SCHEME_UNDEFINED);
232END
233))
234
235(define (byte-blob-intersperse b x)
236  (let ((blen   (byte-blob-size b)))
237    (if (<= blen 1) b
238        (let* ((ob     (byte-blob-object b))
239               (b1len  (- (* 2 blen) 1))
240               (ob1    (make-blob b1len)))
241          (blob-intersperse ob ob1 x (byte-blob-offset b) blen )
242          (make-byte-blob ob1 0)))))
243
244
245(define (byte-blob-take b n)
246  (assert (positive? n))
247  (let ((blen   (byte-blob-size b)))
248    (if (< blen n) b
249        (let* ((ob     (byte-blob-object b))
250               (ob1    (make-blob n)))
251          (move-memory! ob ob1 n (byte-blob-offset b) 0)
252          (make-byte-blob ob1 0)))))
253 
254
255(define (byte-blob-drop b n)
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))))))
260
261
262(define (byte-blob-span b start end)
263  (assert (and (or (zero? start) (positive? start)) (positive? end) (< start end)))
264  (byte-blob-take (byte-blob-drop b start) (- end start)))
265
266(define (byte-blob-map f b)
267  (let* ((blen  (byte-blob-size b))
268         (ob    (byte-blob-object b))
269         (ob1   (make-blob blen)))
270    (let loop ((i blen) (p (+ blen (byte-blob-offset b))))
271      (if (positive? i) 
272          (let ((p (- p 1)))
273            (blob-set! ob1 p (f (blob-ref ob p)))
274            (loop (- i 1) p))
275          (make-byte-blob ob1 0)))))
276   
277
278(define (byte-blob-fold-right f init b)
279  (let* ((blen  (byte-blob-size b))
280         (ob    (byte-blob-object b)))
281    (let loop ((i blen) (p (+ blen (byte-blob-offset b))) (ax init))
282      (if (positive? i) 
283          (let ((p (- p 1)))
284            (loop (- i 1) p (f (blob-ref ob p) ax)))
285          ax))))
286
287   
288(define (byte-blob-fold-left f init b)
289  (let* ((blen  (byte-blob-size b))
290         (ob    (byte-blob-object b)))
291    (let loop ((i blen) (p (byte-blob-offset b))
292               (ax init))
293      (if (positive? i) 
294          (loop (- i 1) (+ 1 p) (f (blob-ref ob p) ax))
295          ax))))
296   
297       
298(define (byte-blob->list b)
299  (let loop ((b b) (ax '()))
300    (cond ((byte-blob-empty? b) (reverse ax))
301          (else  (loop (byte-blob-cdr b) (cons (byte-blob-car b) ax))))))
302         
303(define (byte-blob->string b)
304  (blob->string (byte-blob-object b)))
305
306
307
308;; The following three functions are borrowed from the
309;; Chicken-specific parts of SWIG
310#>
311static void chicken_Panic (C_char *) C_noret;
312static void chicken_Panic (C_char *msg)
313{
314  C_word *a = C_alloc (C_SIZEOF_STRING (strlen (msg)));
315  C_word scmmsg = C_string2 (&a, msg);
316  C_halt (scmmsg);
317  exit (5); /* should never get here */
318}
319
320static void chicken_ThrowException(C_word value) C_noret;
321static void chicken_ThrowException(C_word value)
322{
323  char *aborthook = C_text("\003sysabort");
324
325  C_word *a = C_alloc(C_SIZEOF_STRING(strlen(aborthook)));
326  C_word abort = C_intern2(&a, aborthook);
327
328  abort = C_block_item(abort, 0);
329  if (C_immediatep(abort))
330    Chicken_Panic(C_text("`##sys#abort' is not defined"));
331
332  C_save(value);
333  C_do_apply(1, abort, C_SCHEME_UNDEFINED);
334}
335
336void chicken_io_exception (int code, int msglen, const char *msg) 
337{
338  C_word *a;
339  C_word scmmsg;
340  C_word list;
341
342  a = C_alloc (C_SIZEOF_STRING (msglen) + C_SIZEOF_LIST(2));
343  scmmsg = C_string2 (&a, (char *) msg);
344  list = C_list(&a, 2, C_fix(code), scmmsg);
345  chicken_ThrowException(list);
346}
347
348<#
349
350
351
352(define blob-read
353    (foreign-lambda* unsigned-int ((integer fd) (nonnull-blob b) (integer n) )
354#<<END
355     ssize_t s;
356
357     if ( (s = read(fd,b,n)) == -1 )
358     {
359          chicken_io_exception (-1,32,"read I/O error in byte-blob-read");
360     }
361     if (s == 0) chicken_io_exception (-1,32,"EOF reached in byte-blob-read");
362
363     C_return(s);
364END
365))
366
367
368(define (byte-blob-read port n)
369  (let ((ob (make-blob n)))
370    (blob-read (port->fileno port) ob n)
371    (make-byte-blob ob 0)))
372
373
374(define blob-write
375    (foreign-lambda* void ((integer fd) (nonnull-blob b) (integer size) (integer offset))
376#<<END
377     ssize_t s,n;
378
379     n = s = 0;
380     while (n < size)
381     {
382          if ( (s = write(fd,(const void *)(b+n+offset),size-n)) == -1 )
383          {
384               chicken_io_exception (-1,32,"write I/O error in byte-blob-write");
385               return -1;
386          }
387          n += s;
388     }
389     C_return(C_SCHEME_UNDEFINED);
390END
391))
392
393(define (byte-blob-write port b)
394  (let ((ob (byte-blob-object b))
395        (n  (byte-blob-size b))
396        (offset (byte-blob-offset b)))
397    (blob-write (port->fileno port) ob n offset)))
398
399
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
447
448)
Note: See TracBrowser for help on using the repository browser.