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

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

initial import of endian-blob

File size: 9.4 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 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 b)
164  (let* ((alen  (byte-blob-size a))
165         (blen  (byte-blob-size b))
166         (ablen (+ alen blen))
167         (ab    (make-blob ablen)))
168    (move-memory! (byte-blob-object a) ab alen (byte-blob-offset a) 0)
169    (move-memory! (byte-blob-object b) ab blen (byte-blob-offset b) alen)
170    (make-byte-blob ab 0)))
171   
172
173(define blob-reverse 
174    (foreign-lambda* void ((nonnull-blob b) (nonnull-blob b1) (integer offset) (integer size))
175#<<END
176   int i,p;
177   for (i=offset,p=size-1; p>=0; i++,p--)
178   {
179      b1[p] = b[i];
180   }
181
182   C_return (C_SCHEME_UNDEFINED);
183END
184))
185
186(define (byte-blob-reverse b)
187  (let* ((blen   (byte-blob-size b))
188         (ob     (byte-blob-object b))
189         (ob1    (make-blob blen)))
190    (blob-reverse ob ob1 (byte-blob-offset b) blen)
191    (make-byte-blob ob1 0)))
192
193
194(define blob-intersperse 
195    (foreign-lambda* void ((nonnull-blob b) (nonnull-blob b1) (byte sep) (integer offset) (integer size))
196#<<END
197   int i,p,n;
198   b1[0]=b[offset];
199   for (i=offset+1,p=1,n=size-1; n>0; i++,p+=2,n--)
200   {
201      b1[p] = sep;
202      b1[p+1] = b[i];
203   }
204
205   C_return (C_SCHEME_UNDEFINED);
206END
207))
208
209(define (byte-blob-intersperse b x)
210  (let ((blen   (byte-blob-size b)))
211    (if (<= blen 1) b
212        (let* ((ob     (byte-blob-object b))
213               (b1len  (- (* 2 blen) 1))
214               (ob1    (make-blob b1len)))
215          (blob-intersperse ob ob1 x (byte-blob-offset b) blen )
216          (make-byte-blob ob1 0)))))
217
218
219(define (byte-blob-take b n)
220  (assert (positive? n))
221  (let ((blen   (byte-blob-size b)))
222    (if (< blen n) b
223        (let* ((ob     (byte-blob-object b))
224               (ob1    (make-blob n)))
225          (move-memory! ob ob1 n (byte-blob-offset b) 0)
226          (make-byte-blob ob1 0)))))
227 
228
229(define (byte-blob-drop b n)
230  (assert (positive? n))
231  (let ((blen   (byte-blob-size b)))
232    (if (< blen n) (byte-blob-empty)
233        (let* ((ob     (byte-blob-object b))
234               (ob1    (make-blob (- blen n))))
235          (move-memory! ob ob1 (- blen n) (+ n (byte-blob-offset b)) 0)
236          (make-byte-blob ob1 0)))))
237 
238
239
240(define (byte-blob-map f b)
241  (let* ((blen  (byte-blob-size b))
242         (ob    (byte-blob-object b))
243         (ob1   (make-blob blen)))
244    (let loop ((i blen) (p (+ blen (byte-blob-offset b))))
245      (if (positive? i) 
246          (let ((p (- p 1)))
247            (blob-set! ob1 p (f (blob-ref ob p)))
248            (loop (- i 1) p))
249          (make-byte-blob ob1 0)))))
250   
251
252(define (byte-blob-fold-right f init b)
253  (let* ((blen  (byte-blob-size b))
254         (ob    (byte-blob-object b)))
255    (let loop ((i blen) (p (+ blen (byte-blob-offset b))) (ax init))
256      (if (positive? i) 
257          (let ((p (- p 1)))
258            (loop (- i 1) p (f (blob-ref ob p) ax)))
259          ax))))
260
261   
262(define (byte-blob-fold-left f init b)
263  (let* ((blen  (byte-blob-size b))
264         (ob    (byte-blob-object b)))
265    (let loop ((i blen) (p (byte-blob-offset b))
266               (ax init))
267      (if (positive? i) 
268          (loop (- i 1) (+ 1 p) (f (blob-ref ob p) ax))
269          ax))))
270   
271       
272(define (byte-blob->list b)
273  (let loop ((b b) (ax '()))
274    (cond ((byte-blob-empty? b) (reverse ax))
275          (else  (loop (byte-blob-cdr b) (cons (byte-blob-car b) ax))))))
276         
277(define (byte-blob->string b)
278  (blob->string (byte-blob-object b)))
279
280
281
282;; The following three functions are borrowed from the
283;; Chicken-specific parts of SWIG
284#>
285static void chicken_Panic (C_char *) C_noret;
286static void chicken_Panic (C_char *msg)
287{
288  C_word *a = C_alloc (C_SIZEOF_STRING (strlen (msg)));
289  C_word scmmsg = C_string2 (&a, msg);
290  C_halt (scmmsg);
291  exit (5); /* should never get here */
292}
293
294static void chicken_ThrowException(C_word value) C_noret;
295static void chicken_ThrowException(C_word value)
296{
297  char *aborthook = C_text("\003sysabort");
298
299  C_word *a = C_alloc(C_SIZEOF_STRING(strlen(aborthook)));
300  C_word abort = C_intern2(&a, aborthook);
301
302  abort = C_block_item(abort, 0);
303  if (C_immediatep(abort))
304    Chicken_Panic(C_text("`##sys#abort' is not defined"));
305
306  C_save(value);
307  C_do_apply(1, abort, C_SCHEME_UNDEFINED);
308}
309
310void chicken_io_exception (int code, int msglen, const char *msg) 
311{
312  C_word *a;
313  C_word scmmsg;
314  C_word list;
315
316  a = C_alloc (C_SIZEOF_STRING (msglen) + C_SIZEOF_LIST(2));
317  scmmsg = C_string2 (&a, (char *) msg);
318  list = C_list(&a, 2, C_fix(code), scmmsg);
319  chicken_ThrowException(list);
320}
321
322<#
323
324
325
326(define blob-read
327    (foreign-lambda* unsigned-int ((integer fd) (nonnull-blob b) (integer n) )
328#<<END
329     ssize_t s;
330
331     if ( (s = read(fd,b,n)) == -1 )
332     {
333          chicken_io_exception (-1,32,"read I/O error in byte-blob-read");
334     }
335     if (s == 0) chicken_io_exception (-1,32,"EOF reached in byte-blob-read");
336
337     C_return(s);
338END
339))
340
341
342(define (byte-blob-read port n)
343  (let ((ob (make-blob n)))
344    (blob-read (port->fileno port) ob n)
345    (make-byte-blob ob 0)))
346
347
348(define blob-write
349    (foreign-lambda* void ((integer fd) (nonnull-blob b) (integer size) (integer offset))
350#<<END
351     ssize_t s,n;
352
353     n = s = 0;
354     while (n < size)
355     {
356          if ( (s = write(fd,(const void *)(b+n+offset),size-n)) == -1 )
357          {
358               chicken_io_exception (-1,32,"write I/O error in byte-blob-write");
359               return -1;
360          }
361          n += s;
362     }
363     C_return(C_SCHEME_UNDEFINED);
364END
365))
366
367(define (byte-blob-write port b)
368  (let ((ob (byte-blob-object b))
369        (n  (byte-blob-size b))
370        (offset (byte-blob-offset b)))
371    (blob-write (port->fileno port) ob n offset)))
372
373
374
375)
Note: See TracBrowser for help on using the repository browser.