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

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

added byte-blob-span

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-span
57         byte-blob-map
58         byte-blob-fold-left
59         byte-blob-fold-right
60         byte-blob->list
61         byte-blob->string
62         byte-blob-read
63         byte-blob-write
64         )
65
66        (import scheme chicken foreign posix)
67
68        (require-extension srfi-1 lolevel )
69
70
71(define-record-type byte-blob
72  (make-byte-blob object offset )
73  byte-blob?
74  (object       byte-blob-object )
75  (offset       byte-blob-offset )
76  )
77
78(define byte-blob->blob byte-blob-object)
79
80(define (byte-blob-size b)
81  (- (blob-size (byte-blob-object b)) 
82     (byte-blob-offset b)))
83
84(define (byte-blob-empty)
85  (make-byte-blob (make-blob 0) 0))
86
87(define (byte-blob-empty? b)
88  (zero? (byte-blob-size b)))
89
90(define (byte-blob-copy b . rest)
91  (let-optionals rest ((offset (byte-blob-offset b)))
92    (assert (or (positive? offset) (zero? offset)))
93    (make-byte-blob (byte-blob-object b) offset )))
94
95(define blob-set! 
96    (foreign-lambda* void ((nonnull-blob b) (integer offset) (byte value))
97#<<END
98   b[offset] = value;
99END
100))
101
102(define blob-ref 
103    (foreign-lambda* byte ((nonnull-blob b) (integer offset))
104#<<END
105   C_word result;
106   result = b[offset];
107   C_return (result);
108END
109))
110
111(define (list->byte-blob lst)
112  (let* ((len (length lst))
113         (ob  (make-blob len)))
114    (let loop ((lst lst) (i 0))
115      (if (null? lst) (make-byte-blob ob 0)
116          (begin (blob-set! ob i (car lst))
117                 (loop (cdr lst) (+ i 1)))))))
118   
119
120
121(define blob-fill 
122    (foreign-lambda* void ((nonnull-blob b) (unsigned-int n) (integer offset) (byte value))
123#<<END
124   memset((void *)(b+offset),value,n);
125END
126))
127
128(define (byte-blob-replicate n v)
129  (assert (positive? n))
130  (let* ((ob (make-blob n))
131         (bb (make-byte-blob ob 0)))
132    (blob-fill ob n 0 v)
133    bb))
134
135;; 'blob-cons' is analogous to list cons, but of different complexity,
136;; as it requires a memcpy.
137
138(define (byte-blob-cons x b)
139  (let* ((blen  (byte-blob-size b))
140         (b1len (+ 1 blen))
141         (b1    (make-blob b1len)))
142    (blob-set! b1 0 x)
143    (if (positive? blen) 
144        (move-memory! (byte-blob-object b) b1 blen (byte-blob-offset b) 1))
145    (make-byte-blob b1 0)))
146
147(define (byte-blob-car b)
148  (assert (positive? (byte-blob-size b)))
149  (blob-car (byte-blob-object b) (byte-blob-offset b)))
150
151(define blob-car 
152    (foreign-primitive byte ((nonnull-blob b) (integer offset))
153#<<END
154   C_word result;
155   result = b[offset];
156   C_return (result);
157END
158))
159
160(define (byte-blob-cdr b)
161  (assert (positive? (byte-blob-size b)))
162  (byte-blob-copy b (+ 1 (byte-blob-offset b))))
163
164(define (byte-blob-append a . rst)
165  (if (null? rst) a
166      (let* ((rlen  (map byte-blob-size (cons a rst)))
167             (clen  (fold fx+ 0 rlen))
168             (c     (make-blob clen)))
169        (let loop ((pos 0) (lst (cons a rst)) (len rlen))
170          (if (null? lst) (make-byte-blob c 0)
171              (let ((x (car lst))
172                    (xlen (car len)))
173                (move-memory! (byte-blob-object x) c xlen (byte-blob-offset x) pos)
174                (loop (fx+ pos xlen) (cdr lst) (cdr len)))))
175        )))
176
177   
178
179(define blob-reverse 
180    (foreign-lambda* void ((nonnull-blob b) (nonnull-blob b1) (integer offset) (integer size))
181#<<END
182   int i,p;
183   for (i=offset,p=size-1; p>=0; i++,p--)
184   {
185      b1[p] = b[i];
186   }
187
188   C_return (C_SCHEME_UNDEFINED);
189END
190))
191
192(define (byte-blob-reverse b)
193  (let* ((blen   (byte-blob-size b))
194         (ob     (byte-blob-object b))
195         (ob1    (make-blob blen)))
196    (blob-reverse ob ob1 (byte-blob-offset b) blen)
197    (make-byte-blob ob1 0)))
198
199
200(define blob-intersperse 
201    (foreign-lambda* void ((nonnull-blob b) (nonnull-blob b1) (byte sep) (integer offset) (integer size))
202#<<END
203   int i,p,n;
204   b1[0]=b[offset];
205   for (i=offset+1,p=1,n=size-1; n>0; i++,p+=2,n--)
206   {
207      b1[p] = sep;
208      b1[p+1] = b[i];
209   }
210
211   C_return (C_SCHEME_UNDEFINED);
212END
213))
214
215(define (byte-blob-intersperse b x)
216  (let ((blen   (byte-blob-size b)))
217    (if (<= blen 1) b
218        (let* ((ob     (byte-blob-object b))
219               (b1len  (- (* 2 blen) 1))
220               (ob1    (make-blob b1len)))
221          (blob-intersperse ob ob1 x (byte-blob-offset b) blen )
222          (make-byte-blob ob1 0)))))
223
224
225(define (byte-blob-take b n)
226  (assert (positive? n))
227  (let ((blen   (byte-blob-size b)))
228    (if (< blen n) b
229        (let* ((ob     (byte-blob-object b))
230               (ob1    (make-blob n)))
231          (move-memory! ob ob1 n (byte-blob-offset b) 0)
232          (make-byte-blob ob1 0)))))
233 
234
235(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)))))
239
240
241(define (byte-blob-span b start end)
242  (assert (and (positive? start) (positive? end) (< start end)))
243  (byte-blob-take (byte-blob-drop b start) (- end start)))
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.