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

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

added copyright note to byte-blob.

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