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

Last change on this file since 30529 was 30529, checked in by Ivan Raikov, 8 years ago

byte-blob: remove temporary file created by unit tests

File size: 20.8 KB
Line 
1;;
2;;  Utility procedures for manipulating blobs as byte sequences.
3;;
4;;   Copyright 2009-2014 Ivan Raikov and the Okinawa Institute of
5;;   Science and Technology.
6;;
7;;
8;;   This program is free software: you can redistribute it and/or
9;;   modify it under the terms of the GNU General Public License as
10;;   published by the Free Software Foundation, either version 3 of
11;;   the License, or (at your option) any later version.
12;;
13;;   This program is distributed in the hope that it will be useful,
14;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
15;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16;;   General Public License for more details.
17;;
18;;   A full copy of the GPL license can be found at
19;;   <http://www.gnu.org/licenses/>.
20
21(module byte-blob
22
23        (byte-blob?
24         byte-blob-empty?
25         byte-blob-length
26         byte-blob-empty
27         blob->byte-blob
28         list->byte-blob
29         string->byte-blob
30         file->byte-blob
31         byte-blob-replicate
32         byte-blob-object
33         byte-blob-offset
34         byte-blob-cons 
35         byte-blob-car
36         byte-blob-cdr
37         byte-blob-ref
38         byte-blob-uref
39         byte-blob-set!
40         byte-blob-uset!
41         byte-blob-append
42         byte-blob-reverse
43         byte-blob-intersperse
44         byte-blob-take
45         byte-blob-drop
46         byte-blob-span
47         byte-blob-map
48         byte-blob-fold-left
49         byte-blob-fold-right
50         byte-blob-find
51         byte-blob->list
52         byte-blob->string
53         byte-blob-read
54         byte-blob-write
55
56         u8vector->byte-blob 
57         s8vector->byte-blob 
58         u16vector->byte-blob 
59         s16vector->byte-blob 
60         u32vector->byte-blob 
61         s32vector->byte-blob 
62         f32vector->byte-blob 
63         f64vector->byte-blob 
64         
65         byte-blob->u8vector 
66         byte-blob->s8vector 
67         byte-blob->u16vector 
68         byte-blob->s16vector 
69         byte-blob->u32vector 
70         byte-blob->s32vector 
71         byte-blob->f32vector 
72         byte-blob->f64vector 
73
74         
75         )
76
77        (import scheme chicken data-structures foreign )
78
79        (require-extension srfi-1 lolevel posix)
80
81
82(define-record-type byte-blob
83  (make-byte-blob object offset length )
84  byte-blob?
85  (object       byte-blob-object )
86  (offset       byte-blob-offset )
87  (length       byte-blob-length )
88  )
89
90
91(define byte-blob->blob byte-blob-object)
92
93(define (blob->byte-blob b)
94  (and (blob? b) (make-byte-blob b 0 (blob-size b))))
95
96(define (byte-blob-empty)
97  (make-byte-blob (make-blob 0) 0 0))
98
99(define (byte-blob-empty? b)
100  (zero? (byte-blob-length b)))
101
102(define (byte-blob-copy b 
103                        #!optional
104                        (offset (byte-blob-offset b))
105                        (length (byte-blob-length b)))
106  (assert (and (or (positive? offset) (zero? offset))
107               (or (positive? length) (zero? length))
108               (>= (- (blob-size (byte-blob-object b)) offset) length)))
109  (make-byte-blob (byte-blob-object b) offset length ))
110
111(define blob-set! 
112    (foreign-lambda* void ((nonnull-blob b) (integer offset) (byte value))
113#<<END
114   b[offset] = value;
115END
116))
117
118(define (byte-blob-set! b i v)
119  (let ((ob (byte-blob-object b))
120        (offset (byte-blob-offset b))
121        (length (byte-blob-length b)))
122    (assert (and (or (zero? i) (positive? i))  (< i length)))
123    (blob-set! ob (+ offset i) v)))
124
125(define blob-uset! 
126    (foreign-lambda* void ((nonnull-blob b) (integer offset) (unsigned-byte value))
127#<<END
128   b[offset] = value;
129END
130))
131
132(define (byte-blob-uset! b i v)
133  (let ((ob (byte-blob-object b))
134        (offset (byte-blob-offset b))
135        (length (byte-blob-length b)))
136    (assert (and (or (zero? i) (positive? i))  (< i length)))
137    (blob-uset! ob (+ offset i) v)))
138
139(define blob-ref 
140    (foreign-lambda* byte ((nonnull-blob b) (integer offset))
141#<<END
142   C_word result;
143   result = b[offset];
144   C_return (result);
145END
146))
147
148(define (byte-blob-ref b i)
149  (let ((ob (byte-blob-object b))
150        (offset (byte-blob-offset b))
151        (length (byte-blob-length b)))
152    (assert (and (or (zero? i) (positive? i))  (< i length)))
153    (blob-ref ob (+ offset i))))
154
155(define blob-uref 
156    (foreign-lambda* unsigned-byte ((nonnull-blob b) (integer offset))
157#<<END
158   C_word result;
159   result = b[offset];
160   C_return (result);
161END
162))
163
164(define (byte-blob-uref b i)
165  (let ((ob (byte-blob-object b))
166        (offset (byte-blob-offset b))
167        (length (byte-blob-length b)))
168    (assert (and (or (zero? i) (positive? i))  (< i length)))
169    (blob-uref ob (+ offset i))))
170
171(define blob-set! 
172    (foreign-lambda* void ((nonnull-blob b) (integer offset) (byte v))
173#<<END
174   b[offset] = v;
175END
176))
177
178(define (list->byte-blob lst)
179  (let* ((len (length lst))
180         (ob  (make-blob len)))
181    (let loop ((lst lst) (i 0))
182      (if (null? lst) (make-byte-blob ob 0 len)
183          (begin (blob-set! ob i (car lst))
184                 (loop (cdr lst) (+ i 1)))))))
185   
186(define (string->byte-blob str)
187  (make-byte-blob (string->blob str) 0 (string-length str)))
188
189(define blob-fill 
190    (foreign-lambda* void ((nonnull-blob b) (unsigned-int n) (integer offset) (byte value))
191#<<END
192   memset((void *)(b+offset),value,n);
193END
194))
195
196(define (byte-blob-replicate n v)
197  (assert (positive? n))
198  (let* ((ob (make-blob n))
199         (bb (make-byte-blob ob 0 n)))
200    (blob-fill ob n 0 v)
201    bb))
202
203;; 'blob-cons' is analogous to list cons, but of different complexity,
204;; as it requires a memcpy.
205
206(define (byte-blob-cons x b)
207  (let* ((blen  (byte-blob-length b))
208         (b1len (+ 1 blen))
209         (b1    (make-blob b1len)))
210    (blob-set! b1 0 x)
211    (if (positive? blen) 
212        (move-memory! (byte-blob-object b) b1 blen (byte-blob-offset b) 1))
213    (make-byte-blob b1 0 b1len)))
214
215(define (byte-blob-car b)
216  (assert (positive? (byte-blob-length b)))
217  (blob-car (byte-blob-object b) (byte-blob-offset b)))
218
219(define blob-car 
220    (foreign-primitive byte ((nonnull-blob b) (integer offset))
221#<<END
222   C_word result;
223   result = b[offset];
224   C_return (result);
225END
226))
227
228(define (byte-blob-cdr b)
229  (let ((n (byte-blob-length b)))
230    (assert (positive? n))
231    (byte-blob-copy b (+ 1 (byte-blob-offset b)) (- n 1))))
232
233(define (byte-blob-append a . rst)
234  (if (null? rst) a
235      (let* ((rlen  (map byte-blob-length (cons a rst)))
236             (clen  (fold + 0 rlen))
237             (c     (make-blob clen)))
238        (let loop ((pos 0) (lst (cons a rst)) (len rlen))
239          (if (null? lst) (make-byte-blob c 0 clen)
240              (let ((x (car lst))
241                    (xlen (car len)))
242                (move-memory! (byte-blob-object x) c xlen (byte-blob-offset x) pos)
243                (loop (+ pos xlen) (cdr lst) (cdr len)))))
244        )))
245
246   
247
248(define blob-reverse 
249    (foreign-lambda* void ((nonnull-blob b) (nonnull-blob b1) (integer offset) (integer size))
250#<<END
251   int i,p;
252   for (i=offset,p=size-1; p>=0; i++,p--)
253   {
254      b1[p] = b[i];
255   }
256
257   C_return (C_SCHEME_UNDEFINED);
258END
259))
260
261(define (byte-blob-reverse b)
262  (let* ((blen   (byte-blob-length b))
263         (ob     (byte-blob-object b))
264         (ob1    (make-blob blen)))
265    (blob-reverse ob ob1 (byte-blob-offset b) blen)
266    (make-byte-blob ob1 0 blen)))
267
268
269(define blob-intersperse 
270    (foreign-lambda* void ((nonnull-blob b) (nonnull-blob b1) (byte sep) (integer offset) (integer size))
271#<<END
272   int i,p,n;
273   b1[0]=b[offset];
274   for (i=offset+1,p=1,n=size-1; n>0; i++,p+=2,n--)
275   {
276      b1[p] = sep;
277      b1[p+1] = b[i];
278   }
279
280   C_return (C_SCHEME_UNDEFINED);
281END
282))
283
284(define (byte-blob-intersperse b x)
285  (let ((blen   (byte-blob-length b)))
286    (if (<= blen 1) b
287        (let* ((ob     (byte-blob-object b))
288               (b1len  (- (* 2 blen) 1))
289               (ob1    (make-blob b1len)))
290          (blob-intersperse ob ob1 x (byte-blob-offset b) blen )
291          (make-byte-blob ob1 0 b1len)))))
292
293
294(define (byte-blob-take b n)
295  (assert (positive? n))
296  (let ((blen   (byte-blob-length b)))
297    (if (< blen n) b
298        (let* ((ob     (byte-blob-object b))
299               (ob1    (make-blob n)))
300          (move-memory! ob ob1 n (byte-blob-offset b) 0)
301          (make-byte-blob ob1 0 n)))))
302 
303
304(define (byte-blob-drop b n)
305  (if (zero? n) b
306      (let ((blen   (byte-blob-length b)))
307        (assert (and (positive? n) (<= n blen)))
308        (byte-blob-copy b (+ n (byte-blob-offset b)) (- blen n)))))
309
310
311(define (byte-blob-span b start end)
312  (assert (and (or (zero? start) (positive? start)) (positive? end) (< start end)))
313  (byte-blob-take (byte-blob-drop b start) (- end start)))
314
315
316(define (byte-blob-map f b)
317  (let* ((blen  (byte-blob-length b))
318         (ob    (byte-blob-object b))
319         (ob1   (make-blob blen)))
320    (let loop ((i blen) (p (+ blen (byte-blob-offset b))))
321      (if (positive? i) 
322          (let ((p (- p 1)))
323            (blob-set! ob1 p (f (blob-ref ob p)))
324            (loop (- i 1) p))
325          (make-byte-blob ob1 0 blen)))))
326   
327
328(define (byte-blob-fold-right f init b)
329  (let* ((blen  (byte-blob-length b))
330         (ob    (byte-blob-object b)))
331    (let loop ((i blen) (p (+ blen (byte-blob-offset b))) (ax init))
332      (if (positive? i) 
333          (let ((p (- p 1)))
334            (loop (- i 1) p (f (blob-ref ob p) ax)))
335          ax))))
336
337   
338(define (byte-blob-fold-left f init b)
339  (let* ((blen  (byte-blob-length b))
340         (ob    (byte-blob-object b)))
341    (let loop ((i blen) (p (byte-blob-offset b))
342               (ax init))
343      (if (positive? i) 
344          (loop (- i 1) (+ 1 p) (f (blob-ref ob p) ax))
345          ax))))
346   
347       
348(define (byte-blob->list b . rest)
349  (let-optionals rest ((fmap identity))
350   (let loop ((b b) (ax '()))
351     (cond ((byte-blob-empty? b) (reverse ax))
352           (else  (loop (byte-blob-cdr b) (cons (fmap (byte-blob-car b)) ax)))))))
353         
354(define (byte-blob->string b)
355  (blob->string (byte-blob-object b)))
356
357(define (byte-blob->string b)
358  (assert (byte-blob? b))
359  (let* ([n (byte-blob-length b)]
360         [s (make-string n)] )
361    (move-memory! (byte-blob-object b) s n (byte-blob-offset b) 0)
362    s))
363
364
365;; The following three functions are borrowed from the
366;; Chicken-specific parts of SWIG
367#>
368static void chicken_Panic (C_char *) C_noret;
369static void chicken_Panic (C_char *msg)
370{
371  C_word *a = C_alloc (C_SIZEOF_STRING (strlen (msg)));
372  C_word scmmsg = C_string2 (&a, msg);
373  C_halt (scmmsg);
374  exit (5); /* should never get here */
375}
376
377static void chicken_ThrowException(C_word value) C_noret;
378static void chicken_ThrowException(C_word value)
379{
380  char *aborthook = C_text("\003sysabort");
381
382  C_word *a = C_alloc(C_SIZEOF_STRING(strlen(aborthook)));
383  C_word abort = C_intern2(&a, aborthook);
384
385  abort = C_block_item(abort, 0);
386  if (C_immediatep(abort))
387    chicken_Panic(C_text("`##sys#abort' is not defined"));
388
389  C_save(value);
390  C_do_apply(1, abort, C_SCHEME_UNDEFINED);
391}
392
393void chicken_io_exception (int code, int msglen, const char *msg) 
394{
395  C_word *a;
396  C_word scmmsg;
397  C_word list;
398
399  a = C_alloc (C_SIZEOF_STRING (msglen) + C_SIZEOF_LIST(2));
400  scmmsg = C_string2 (&a, (char *) msg);
401  list = C_list(&a, 2, C_fix(code), scmmsg);
402  chicken_ThrowException(list);
403}
404
405<#
406
407
408
409(define blob-read
410    (foreign-lambda* int ((integer fd) (nonnull-blob b) (integer n) )
411#<<END
412     ssize_t s;
413
414     if ( (s = read(fd,b,n)) == -1 )
415     {
416          chicken_io_exception (-1,32,"read I/O error in byte-blob-read");
417     }
418     C_return(s);
419END
420))
421
422
423(define (byte-blob-read port n)
424  (let ((ob (make-blob n)))
425    (let ((s (blob-read (port->fileno port) ob n)))
426      (if (positive? s)
427          (make-byte-blob ob 0 s)
428          #!eof))))
429
430       
431(define (file->byte-blob filename . rest)
432  (let ((filesize (file-size filename)))
433    (call-with-input-file filename
434      (lambda (port) (byte-blob-read port filesize)))))
435
436
437(define blob-write
438    (foreign-lambda* void ((integer fd) (nonnull-blob b) (integer size) (integer offset))
439#<<END
440     ssize_t s,n;
441
442     n = s = 0;
443     while (n < size)
444     {
445          if ( (s = write(fd,(const void *)(b+n+offset),size-n)) == -1 )
446          {
447               chicken_io_exception (-1,32,"write I/O error in byte-blob-write");
448               return -1;
449          }
450          n += s;
451     }
452     C_return(C_SCHEME_UNDEFINED);
453END
454))
455
456(define (byte-blob-write port b)
457  (let ((ob (byte-blob-object b))
458        (n  (byte-blob-length b))
459        (offset (byte-blob-offset b)))
460    (blob-write (port->fileno port) ob n offset)))
461
462
463;; code borrowed from srfi-4.scm:
464
465(define (pack-copy tag loc)
466  (lambda (v)
467    (##sys#check-structure v tag loc)
468    (let* ((old (##sys#slot v 1))
469           (n   (##sys#size old))
470           (new (##sys#make-blob n)))
471      (move-memory! old new)
472      (make-byte-blob new 0 n)
473      )))
474
475(define u8vector->byte-blob (pack-copy 'u8vector 'u8vector->byte-blob))
476(define s8vector->byte-blob (pack-copy 's8vector 's8vector->byte-blob))
477(define u16vector->byte-blob (pack-copy 'u16vector 'u16vector->byte-blob))
478(define s16vector->byte-blob (pack-copy 's16vector 's16vector->byte-blob))
479(define u32vector->byte-blob (pack-copy 'u32vector 'u32vector->byte-blob))
480(define s32vector->byte-blob (pack-copy 's32vector 's32vector->byte-blob))
481(define f32vector->byte-blob (pack-copy 'f32vector 'f32vector->byte-blob))
482(define f64vector->byte-blob (pack-copy 'f64vector 'f64vector->byte-blob))
483
484
485(define (unpack-copy tag sz loc)
486  (lambda (bb)
487    (let ((str (byte-blob-object bb))
488          (offset (byte-blob-offset bb)))
489      (##sys#check-byte-vector str loc)
490      (let* ((len (byte-blob-length bb))
491             (new (##sys#make-blob len)))
492        (if (or (eq? #t sz)
493                (eq? 0 (##core#inline "C_fixnum_modulo" len sz)))
494            (begin
495              (move-memory! str new len offset) 
496              (##sys#make-structure
497               tag new))
498            (##sys#error loc "blob does not have correct size for packing" tag len sz) ) ) ) ))
499
500
501(define byte-blob->u8vector (unpack-copy 'u8vector #t 'byte-blob->u8vector))
502(define byte-blob->s8vector (unpack-copy 's8vector #t 'byte-blob->s8vector))
503(define byte-blob->u16vector (unpack-copy 'u16vector 2 'byte-blob->u16vector))
504(define byte-blob->s16vector (unpack-copy 's16vector 2 'byte-blob->s16vector))
505(define byte-blob->u32vector (unpack-copy 'u32vector 4 'byte-blob->u32vector))
506(define byte-blob->s32vector (unpack-copy 's32vector 4 'byte-blob->s32vector))
507(define byte-blob->f32vector (unpack-copy 'f32vector 4 'byte-blob->f32vector))
508(define byte-blob->f64vector (unpack-copy 'f64vector 8 'byte-blob->f64vector))
509
510;;
511;;
512;; Fast sub-sequence search, based on work by Boyer, Moore, Horspool,
513;; Sunday, and Lundh.
514;;
515;; Based on code from the Haskell text library by Tom Harper and Bryan
516;; O'Sullivan. http://hackage.haskell.org/package/text
517;;
518;;
519;; References:
520;;
521;; * R. S. Boyer, J. S. Moore: A Fast String Searching Algorithm.
522;;   Communications of the ACM, 20, 10, 762-772 (1977)
523;;
524;; * R. N. Horspool: Practical Fast Searching in Strings.  Software -
525;;   Practice and Experience 10, 501-506 (1980)
526;;
527;; * D. M. Sunday: A Very Fast Substring Search Algorithm.
528;;   Communications of the ACM, 33, 8, 132-142 (1990)
529;;
530;; * F. Lundh: The Fast Search Algorithm.
531;;   <http://effbot.org/zone/stringlib.htm> (2006)
532;;
533;; From http://effbot.org/zone/stringlib.htm:
534;;
535;; When designing the new algorithm, I used the following constraints:
536;;
537;;     * should be faster than the current brute-force algorithm for
538;;       all test cases (based on real-life code), including Jim
539;;       Hugunin’s worst-case test
540;;
541;;     * small setup overhead; no dynamic allocation in the fast path
542;;       (O(m) for speed, O(1) for storage)
543;;
544;;     * sublinear search behaviour in good cases (O(n/m))
545;;
546;;     * no worse than the current algorithm in worst case (O(nm))
547;;
548;;     * should work well for both 8-bit strings and 16-bit or 32-bit
549;;       Unicode strings (no O(σ) dependencies)
550;;
551;;     * many real-life searches should be good, very few should be
552;;       worst case
553;;
554;;     * reasonably simple implementation
555;;
556;;  This rules out most standard algorithms (Knuth-Morris-Pratt is not
557;;  sublinear, Boyer-Moore needs tables that depend on both the
558;;  alphabet size and the pattern size, most Boyer-Moore variants need
559;;  tables that depend on the pattern size, etc.).
560;;
561;;  After some tweaking, I came up with a simplication of Boyer-Moore,
562;;  incorporating ideas from Horspool and Sunday. Here’s an outline:
563;;
564;; def find(s, p):
565;;     # find first occurrence of p in s
566;;     n = len(s)
567;;     m = len(p)
568;;     skip = delta1(p)[p[m-1]]
569;;     i = 0
570;;     while i <= n-m:
571;;         if s[i+m-1] == p[m-1]: # (boyer-moore)
572;;             # potential match
573;;             if s[i:i+m-1] == p[:m-1]:
574;;                 return i
575;;             if s[i+m] not in p:
576;;                 i = i + m + 1 # (sunday)
577;;             else:
578;;                 i = i + skip # (horspool)
579;;         else:
580;;             # skip
581;;             if s[i+m] not in p:
582;;                 i = i + m + 1 # (sunday)
583;;             else:
584;;                 i = i + 1
585;;     return -1 # not found
586;;
587;; The delta1(p)[p[m-1]] value is simply the Boyer-Moore delta1 (or
588;; bad-character skip) value for the last character in the pattern.
589;;
590;; For the s[i+m] not in p test, I use a 32-bit bitmask, using the 5
591;; least significant bits of the character as the key. This could be
592;; described as a simple Bloom filter.
593;;
594;; Note that the above Python code may access s[n], which would result in
595;; an IndexError exception. For the CPython implementation, this is not
596;; really a problem, since CPython adds trailing NULL entries to both
597;; 8-bit and Unicode strings. 
598
599;;
600;; /O(n+m)/ Find the offsets of all non-overlapping indices of
601;; needle within haystack.
602;;
603;; In (unlikely) bad cases, this algorithm's complexity degrades
604;; towards /O(n*m)/.
605;;
606
607
608
609(define swizzle
610    (foreign-lambda* unsigned-int ((unsigned-int k))
611#<<END
612     unsigned int result;
613
614     result = (k & 0x1F);
615
616     C_return(result);
617END
618))
619
620
621(define initmask
622    (foreign-lambda* void ((blob m))
623#<<END
624    memset (m, 0, 4);
625END
626))
627
628(define setbit!
629    (foreign-lambda* void ((blob m) (unsigned-int i))
630#<<END
631     unsigned int w;
632     w = i / 8;
633
634     m[w] = m[w] | ((1 << i) >> (8*w));
635END
636))
637
638(define bitset? 
639    (foreign-lambda* bool ((blob m) (unsigned-int i))
640#<<END
641     unsigned int w, result;
642     w = i / 8;
643
644     result = m[w] & ((1 << i) >> (8*w));
645END
646))
647 
648
649
650
651(define (make-table nlast nindex nlen z)
652  (lambda (i msk skp)
653    (let loop ((i i) (msk msk) (skp skp))
654      (cond ((>= i nlast) 
655             (begin (setbit! msk (swizzle z))
656                    (values msk skp)))
657            (else        
658             (let* ((c    (nindex i))
659                    (skp1 (cond ((= c z)  (- nlen i 2))
660                                (else     skp))))
661               (setbit! msk (swizzle c))
662               (loop (+ 1 i) msk skp1)))
663            ))
664    ))
665
666             
667(define (scan1 hindex hlen c)
668  (let loop ((i 0) (ax '()))
669    (cond ((>= i hlen)        (reverse ax))
670          ((= (hindex i) c)   (loop (+ 1 i) (cons i ax)))
671          (else               (loop (+ 1 i) ax)))))
672
673
674(define (scan nindex hindex nlast nlen ldiff z mask skip i)
675
676  (define (candidate-match i j)
677    (cond ((>= j nlast)  #t)
678          ((not (= (hindex (+ i j)) (nindex j)))  #f)
679          (else (candidate-match i (+ 1 j)))))
680
681  (let loop ((i i) (ax '()))
682
683    (if (> i ldiff)   (reverse ax)
684
685    (let ((c (hindex (+ i nlast))))
686      (cond
687            ;;
688            ((and (= c z) (candidate-match i 0))
689             (loop (+ i nlen) (cons i ax)))
690            ;;
691            (else
692             (let* ((next-in-pattern?
693                     (not (bitset? mask (swizzle (hindex (+ i nlen))))))
694                    (delta (cond (next-in-pattern? (+ 1 nlen))
695                                 ((= c z)  (+ 1 skip))
696                                 (else     1))))
697               (loop (+ i delta) ax))))))))
698
699
700(define (subsequence-search needle haystack)
701  (let ((nobj  (byte-blob-object needle))
702        (noff  (byte-blob-offset needle))
703        (nlen  (byte-blob-length needle))
704        (hobj  (byte-blob-object haystack))
705        (hoff  (byte-blob-offset haystack))
706        (hlen  (byte-blob-length haystack)))
707    (let* ((nindex   (lambda (k) (blob-ref nobj (+ noff k))))
708           (hindex   (lambda (k) (blob-ref hobj (+ hoff k))))
709           (ldiff    (- hlen nlen))
710           (nlast    (- nlen 1))
711           (z        (nindex nlast))
712           (tbl      (make-table nlast nindex nlen z))
713           (m        (make-blob 4))
714           )
715      (initmask m)
716      (let-values 
717       (((mask skip)  (tbl 0 m (- nlen 2))))
718       (cond ((= 1 nlen) 
719              (scan1 hindex hlen (nindex 0)))
720             ((or (<= nlen 0) (negative? ldiff)) 
721              '())
722             (else
723              (scan nindex hindex nlast nlen ldiff z mask skip 0)))))))
724
725;;
726;; Based on code from the Haskell text library by Tom Harper and Bryan
727;; O'Sullivan. http://hackage.haskell.org/package/text
728;;
729;;    /O(n+m)/ Find all non-overlapping instances of needle in
730;;  haystack.  The first element of the returned pair is the prefix
731;;  of haystack prior to any matches of needle.  The second is a
732;;  list of pairs.
733;;
734;;  The first element of each pair in the list is a span from the
735;;  beginning of a match to the beginning of the next match, while the
736;;  second is a span from the beginning of the match to the end of the
737;;  input.
738;;
739;;  Examples:
740;;
741;;  > find "::" ""
742;;  > ==> ("", [])
743;;  > find "/" "a/b/c/d"
744;;  > ==> ("a", [("/b","/b/c/d"), ("/c","/c/d"), ("/d","/d")])
745;;
746;;  In (unlikely) bad cases, this function's time complexity degrades
747;;  towards /O(n*m)/.
748
749;; find :: Text * Text -> (Text, [(Text, Text)])
750
751(define (byte-blob-find needle haystack)
752  (cond ((byte-blob-empty? needle) 
753         (error 'find "empty pattern" needle))
754        (else
755         (let ((r (subsequence-search needle haystack)))
756           (cond ((null? r) 
757                  (list haystack '()))
758                 (else      
759                  (let* ((hoff  (byte-blob-offset haystack))
760                         (hlen  (byte-blob-length haystack))
761                         (chunk (lambda (n l) (byte-blob-copy haystack (+ hoff n) l)))
762                         (go    (lambda (s xs)
763                                  (let loop ((s s) (xs xs) (ax '()))
764                                    (if (null? xs)
765                                        (let ((c (chunk s (- hlen s))))
766                                          (reverse (cons (list c c) ax)))
767                                        (let ((x (car xs)) (xs (cdr xs)))
768                                          (loop x xs
769                                                (cons (list (chunk s (- x s)) 
770                                                            (chunk s (- hlen s))) 
771                                                      ax)))))))
772                         )
773                    (list (chunk 0 (car r))
774                          (go (car r) (cdr r)))))))
775         )))
776
777
778
779)
Note: See TracBrowser for help on using the repository browser.