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

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

an improvement to byte-blob-append

File size: 9.6 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         byte-blob-replicate
46         byte-blob-object
47         byte-blob-offset
48         byte-blob-cons 
49         byte-blob-car
50         byte-blob-cdr
51         byte-blob-append
52         byte-blob-reverse
53         byte-blob-intersperse
54         byte-blob-take
55         byte-blob-drop
56         byte-blob-map
57         byte-blob-fold-left
58         byte-blob-fold-right
59         byte-blob->list
60         byte-blob->string
61         byte-blob-read
62         byte-blob-write
63         )
64
65        (import scheme chicken foreign posix)
66
67        (require-extension srfi-1 lolevel )
68
69
70(define-record-type byte-blob
71  (make-byte-blob object offset )
72  byte-blob?
73  (object       byte-blob-object )
74  (offset       byte-blob-offset )
75  )
76
77(define byte-blob->blob byte-blob-object)
78
79(define (byte-blob-size b)
80  (- (blob-size (byte-blob-object b)) 
81     (byte-blob-offset b)))
82
83(define (byte-blob-empty)
84  (make-byte-blob (make-blob 0) 0))
85
86(define (byte-blob-empty? b)
87  (zero? (byte-blob-size b)))
88
89(define (byte-blob-copy b . rest)
90  (let-optionals rest ((offset (byte-blob-offset b)))
91    (assert (or (positive? offset) (zero? offset)))
92    (make-byte-blob (byte-blob-object b) offset )))
93
94(define blob-set! 
95    (foreign-lambda* void ((nonnull-blob b) (integer offset) (byte value))
96#<<END
97   b[offset] = value;
98END
99))
100
101(define blob-ref 
102    (foreign-lambda* byte ((nonnull-blob b) (integer offset))
103#<<END
104   C_word result;
105   result = b[offset];
106   C_return (result);
107END
108))
109
110(define (list->byte-blob lst)
111  (let* ((len (length lst))
112         (ob  (make-blob len)))
113    (let loop ((lst lst) (i 0))
114      (if (null? lst) (make-byte-blob ob 0)
115          (begin (blob-set! ob i (car lst))
116                 (loop (cdr lst) (+ i 1)))))))
117   
118
119
120(define blob-fill 
121    (foreign-lambda* void ((nonnull-blob b) (unsigned-int n) (integer offset) (byte value))
122#<<END
123   memset((void *)(b+offset),value,n);
124END
125))
126
127(define (byte-blob-replicate n v)
128  (assert (positive? n))
129  (let* ((ob (make-blob n))
130         (bb (make-byte-blob ob 0)))
131    (blob-fill ob n 0 v)
132    bb))
133
134;; 'blob-cons' is analogous to list cons, but of different complexity,
135;; as it requires a memcpy.
136
137(define (byte-blob-cons x b)
138  (let* ((blen  (byte-blob-size b))
139         (b1len (+ 1 blen))
140         (b1    (make-blob b1len)))
141    (blob-set! b1 0 x)
142    (if (positive? blen) 
143        (move-memory! (byte-blob-object b) b1 blen (byte-blob-offset b) 1))
144    (make-byte-blob b1 0)))
145
146(define (byte-blob-car b)
147  (assert (positive? (byte-blob-size b)))
148  (blob-car (byte-blob-object b) (byte-blob-offset b)))
149
150(define blob-car 
151    (foreign-primitive byte ((nonnull-blob b) (integer offset))
152#<<END
153   C_word result;
154   result = b[offset];
155   C_return (result);
156END
157))
158
159(define (byte-blob-cdr b)
160  (assert (positive? (byte-blob-size b)))
161  (byte-blob-copy b (+ 1 (byte-blob-offset b))))
162
163(define (byte-blob-append a . rst)
164  (if (null? rst) a
165      (let* ((rlen  (map byte-blob-size (cons a rst)))
166             (clen  (fold fx+ 0 rlen))
167             (c     (make-blob clen)))
168        (let loop ((pos 0) (lst (cons a rst)) (len rlen))
169          (if (null? lst) (make-byte-blob c 0)
170              (let ((x (car lst))
171                    (xlen (car len)))
172                (move-memory! (byte-blob-object x) c xlen (byte-blob-offset x) pos)
173                (loop (fx+ pos xlen) (cdr lst) (cdr len)))))
174        )))
175
176   
177
178(define blob-reverse 
179    (foreign-lambda* void ((nonnull-blob b) (nonnull-blob b1) (integer offset) (integer size))
180#<<END
181   int i,p;
182   for (i=offset,p=size-1; p>=0; i++,p--)
183   {
184      b1[p] = b[i];
185   }
186
187   C_return (C_SCHEME_UNDEFINED);
188END
189))
190
191(define (byte-blob-reverse b)
192  (let* ((blen   (byte-blob-size b))
193         (ob     (byte-blob-object b))
194         (ob1    (make-blob blen)))
195    (blob-reverse ob ob1 (byte-blob-offset b) blen)
196    (make-byte-blob ob1 0)))
197
198
199(define blob-intersperse 
200    (foreign-lambda* void ((nonnull-blob b) (nonnull-blob b1) (byte sep) (integer offset) (integer size))
201#<<END
202   int i,p,n;
203   b1[0]=b[offset];
204   for (i=offset+1,p=1,n=size-1; n>0; i++,p+=2,n--)
205   {
206      b1[p] = sep;
207      b1[p+1] = b[i];
208   }
209
210   C_return (C_SCHEME_UNDEFINED);
211END
212))
213
214(define (byte-blob-intersperse b x)
215  (let ((blen   (byte-blob-size b)))
216    (if (<= blen 1) b
217        (let* ((ob     (byte-blob-object b))
218               (b1len  (- (* 2 blen) 1))
219               (ob1    (make-blob b1len)))
220          (blob-intersperse ob ob1 x (byte-blob-offset b) blen )
221          (make-byte-blob ob1 0)))))
222
223
224(define (byte-blob-take b n)
225  (assert (positive? n))
226  (let ((blen   (byte-blob-size b)))
227    (if (< blen n) b
228        (let* ((ob     (byte-blob-object b))
229               (ob1    (make-blob n)))
230          (move-memory! ob ob1 n (byte-blob-offset b) 0)
231          (make-byte-blob ob1 0)))))
232 
233
234(define (byte-blob-drop b n)
235  (assert (positive? n))
236  (let ((blen   (byte-blob-size b)))
237    (if (< blen n) (byte-blob-empty)
238        (let* ((ob     (byte-blob-object b))
239               (ob1    (make-blob (- blen n))))
240          (move-memory! ob ob1 (- blen n) (+ n (byte-blob-offset b)) 0)
241          (make-byte-blob ob1 0)))))
242 
243
244
245(define (byte-blob-map f b)
246  (let* ((blen  (byte-blob-size b))
247         (ob    (byte-blob-object b))
248         (ob1   (make-blob blen)))
249    (let loop ((i blen) (p (+ blen (byte-blob-offset b))))
250      (if (positive? i) 
251          (let ((p (- p 1)))
252            (blob-set! ob1 p (f (blob-ref ob p)))
253            (loop (- i 1) p))
254          (make-byte-blob ob1 0)))))
255   
256
257(define (byte-blob-fold-right f init b)
258  (let* ((blen  (byte-blob-size b))
259         (ob    (byte-blob-object b)))
260    (let loop ((i blen) (p (+ blen (byte-blob-offset b))) (ax init))
261      (if (positive? i) 
262          (let ((p (- p 1)))
263            (loop (- i 1) p (f (blob-ref ob p) ax)))
264          ax))))
265
266   
267(define (byte-blob-fold-left f init b)
268  (let* ((blen  (byte-blob-size b))
269         (ob    (byte-blob-object b)))
270    (let loop ((i blen) (p (byte-blob-offset b))
271               (ax init))
272      (if (positive? i) 
273          (loop (- i 1) (+ 1 p) (f (blob-ref ob p) ax))
274          ax))))
275   
276       
277(define (byte-blob->list b)
278  (let loop ((b b) (ax '()))
279    (cond ((byte-blob-empty? b) (reverse ax))
280          (else  (loop (byte-blob-cdr b) (cons (byte-blob-car b) ax))))))
281         
282(define (byte-blob->string b)
283  (blob->string (byte-blob-object b)))
284
285
286
287;; The following three functions are borrowed from the
288;; Chicken-specific parts of SWIG
289#>
290static void chicken_Panic (C_char *) C_noret;
291static void chicken_Panic (C_char *msg)
292{
293  C_word *a = C_alloc (C_SIZEOF_STRING (strlen (msg)));
294  C_word scmmsg = C_string2 (&a, msg);
295  C_halt (scmmsg);
296  exit (5); /* should never get here */
297}
298
299static void chicken_ThrowException(C_word value) C_noret;
300static void chicken_ThrowException(C_word value)
301{
302  char *aborthook = C_text("\003sysabort");
303
304  C_word *a = C_alloc(C_SIZEOF_STRING(strlen(aborthook)));
305  C_word abort = C_intern2(&a, aborthook);
306
307  abort = C_block_item(abort, 0);
308  if (C_immediatep(abort))
309    Chicken_Panic(C_text("`##sys#abort' is not defined"));
310
311  C_save(value);
312  C_do_apply(1, abort, C_SCHEME_UNDEFINED);
313}
314
315void chicken_io_exception (int code, int msglen, const char *msg) 
316{
317  C_word *a;
318  C_word scmmsg;
319  C_word list;
320
321  a = C_alloc (C_SIZEOF_STRING (msglen) + C_SIZEOF_LIST(2));
322  scmmsg = C_string2 (&a, (char *) msg);
323  list = C_list(&a, 2, C_fix(code), scmmsg);
324  chicken_ThrowException(list);
325}
326
327<#
328
329
330
331(define blob-read
332    (foreign-lambda* unsigned-int ((integer fd) (nonnull-blob b) (integer n) )
333#<<END
334     ssize_t s;
335
336     if ( (s = read(fd,b,n)) == -1 )
337     {
338          chicken_io_exception (-1,32,"read I/O error in byte-blob-read");
339     }
340     if (s == 0) chicken_io_exception (-1,32,"EOF reached in byte-blob-read");
341
342     C_return(s);
343END
344))
345
346
347(define (byte-blob-read port n)
348  (let ((ob (make-blob n)))
349    (blob-read (port->fileno port) ob n)
350    (make-byte-blob ob 0)))
351
352
353(define blob-write
354    (foreign-lambda* void ((integer fd) (nonnull-blob b) (integer size) (integer offset))
355#<<END
356     ssize_t s,n;
357
358     n = s = 0;
359     while (n < size)
360     {
361          if ( (s = write(fd,(const void *)(b+n+offset),size-n)) == -1 )
362          {
363               chicken_io_exception (-1,32,"write I/O error in byte-blob-write");
364               return -1;
365          }
366          n += s;
367     }
368     C_return(C_SCHEME_UNDEFINED);
369END
370))
371
372(define (byte-blob-write port b)
373  (let ((ob (byte-blob-object b))
374        (n  (byte-blob-size b))
375        (offset (byte-blob-offset b)))
376    (blob-write (port->fileno port) ob n offset)))
377
378
379
380)
Note: See TracBrowser for help on using the repository browser.