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

;;
;;  Utility procedures for manipulating blobs as byte sequences.
;;
;;  Copyright 2009 Ivan Raikov.
;;
;; 
;;  Redistribution and use in source and binary forms, with or without
;;  modification, are permitted provided that the following conditions
;;  are met:
;; 
;;  - Redistributions of source code must retain the above copyright
;;  notice, this list of conditions and the following disclaimer.
;; 
;;  - Redistributions in binary form must reproduce the above
;;  copyright notice, this list of conditions and the following
;;  disclaimer in the documentation and/or other materials provided
;;  with the distribution.
;; 
;;  - Neither name of the copyright holders nor the names of its
;;  contributors may be used to endorse or promote products derived
;;  from this software without specific prior written permission.
;; 
;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND THE
;;  CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
;;  INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
;;  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;  DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR THE
;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;  SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;;  LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
;;  USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
;;  AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;;  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
;;  ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;;  POSSIBILITY OF SUCH DAMAGE.
;;

(module byte-blob

        (byte-blob?
         byte-blob-empty?
         byte-blob-size
         byte-blob-empty
         list->byte-blob
         byte-blob-replicate
         byte-blob-object
         byte-blob-offset
         byte-blob-cons 
         byte-blob-car
         byte-blob-cdr
         byte-blob-append
         byte-blob-reverse
         byte-blob-intersperse
         byte-blob-take
         byte-blob-drop
         byte-blob-map
         byte-blob-fold-left
         byte-blob-fold-right
         byte-blob->list
         byte-blob->string
         byte-blob-read
         byte-blob-write
         )

        (import scheme chicken foreign posix)

        (require-extension lolevel )


(define-record-type byte-blob
  (make-byte-blob object offset )
  byte-blob?
  (object       byte-blob-object )
  (offset       byte-blob-offset )
  )

(define byte-blob->blob byte-blob-object)

(define (byte-blob-size b)
  (- (blob-size (byte-blob-object b)) 
     (byte-blob-offset b)))

(define (byte-blob-empty)
  (make-byte-blob (make-blob 0) 0))

(define (byte-blob-empty? b)
  (zero? (byte-blob-size b)))

(define (byte-blob-copy b . rest)
  (let-optionals rest ((offset (byte-blob-offset b)))
    (assert (or (positive? offset) (zero? offset)))
    (make-byte-blob (byte-blob-object b) offset )))

(define blob-set! 
    (foreign-lambda* void ((nonnull-blob b) (integer offset) (byte value))
#<<END
   b[offset] = value;
END
))

(define blob-ref 
    (foreign-lambda* byte ((nonnull-blob b) (integer offset))
#<<END
   C_word result;
   result = b[offset];
   C_return (result);
END
))

(define (list->byte-blob lst)
  (let* ((len (length lst))
         (ob  (make-blob len)))
    (let loop ((lst lst) (i 0))
      (if (null? lst) (make-byte-blob ob 0)
          (begin (blob-set! ob i (car lst))
                 (loop (cdr lst) (+ i 1)))))))
    


(define blob-fill 
    (foreign-lambda* void ((nonnull-blob b) (unsigned-int n) (integer offset) (byte value))
#<<END
   memset((void *)(b+offset),value,n);
END
))

(define (byte-blob-replicate n v)
  (assert (positive? n))
  (let* ((ob (make-blob n))
         (bb (make-byte-blob ob 0)))
    (blob-fill ob n 0 v)
    bb))

;; 'blob-cons' is analogous to list cons, but of different complexity,
;; as it requires a memcpy.

(define (byte-blob-cons x b)
  (let* ((blen  (byte-blob-size b))
         (b1len (+ 1 blen))
         (b1    (make-blob b1len)))
    (blob-set! b1 0 x)
    (if (positive? blen) 
        (move-memory! (byte-blob-object b) b1 blen (byte-blob-offset b) 1))
    (make-byte-blob b1 0)))

(define (byte-blob-car b)
  (assert (positive? (byte-blob-size b)))
  (blob-car (byte-blob-object b) (byte-blob-offset b)))

(define blob-car 
    (foreign-primitive byte ((nonnull-blob b) (integer offset))
#<<END
   C_word result;
   result = b[offset];
   C_return (result);
END
))

(define (byte-blob-cdr b)
  (assert (positive? (byte-blob-size b)))
  (byte-blob-copy b (+ 1 (byte-blob-offset b))))

(define (byte-blob-append a b)
  (let* ((alen  (byte-blob-size a))
         (blen  (byte-blob-size b))
         (ablen (+ alen blen))
         (ab    (make-blob ablen)))
    (move-memory! (byte-blob-object a) ab alen (byte-blob-offset a) 0)
    (move-memory! (byte-blob-object b) ab blen (byte-blob-offset b) alen)
    (make-byte-blob ab 0)))
    

(define blob-reverse 
    (foreign-lambda* void ((nonnull-blob b) (nonnull-blob b1) (integer offset) (integer size))
#<<END
   int i,p;
   for (i=offset,p=size-1; p>=0; i++,p--)
   {
      b1[p] = b[i];
   }

   C_return (C_SCHEME_UNDEFINED);
END
))

(define (byte-blob-reverse b)
  (let* ((blen   (byte-blob-size b))
         (ob     (byte-blob-object b))
         (ob1    (make-blob blen)))
    (blob-reverse ob ob1 (byte-blob-offset b) blen)
    (make-byte-blob ob1 0)))


(define blob-intersperse 
    (foreign-lambda* void ((nonnull-blob b) (nonnull-blob b1) (byte sep) (integer offset) (integer size))
#<<END
   int i,p,n;
   b1[0]=b[offset];
   for (i=offset+1,p=1,n=size-1; n>0; i++,p+=2,n--)
   {
      b1[p] = sep;
      b1[p+1] = b[i];
   }

   C_return (C_SCHEME_UNDEFINED);
END
))

(define (byte-blob-intersperse b x)
  (let ((blen   (byte-blob-size b)))
    (if (<= blen 1) b
        (let* ((ob     (byte-blob-object b))
               (b1len  (- (* 2 blen) 1))
               (ob1    (make-blob b1len)))
          (blob-intersperse ob ob1 x (byte-blob-offset b) blen )
          (make-byte-blob ob1 0)))))


(define (byte-blob-take b n)
  (assert (positive? n))
  (let ((blen   (byte-blob-size b)))
    (if (< blen n) b
        (let* ((ob     (byte-blob-object b))
               (ob1    (make-blob n)))
          (move-memory! ob ob1 n (byte-blob-offset b) 0)
          (make-byte-blob ob1 0)))))
  

(define (byte-blob-drop b n)
  (assert (positive? n))
  (let ((blen   (byte-blob-size b)))
    (if (< blen n) (byte-blob-empty)
        (let* ((ob     (byte-blob-object b))
               (ob1    (make-blob (- blen n))))
          (move-memory! ob ob1 (- blen n) (+ n (byte-blob-offset b)) 0)
          (make-byte-blob ob1 0)))))
  


(define (byte-blob-map f b)
  (let* ((blen  (byte-blob-size b))
         (ob    (byte-blob-object b))
         (ob1   (make-blob blen)))
    (let loop ((i blen) (p (+ blen (byte-blob-offset b))))
      (if (positive? i) 
          (let ((p (- p 1)))
            (blob-set! ob1 p (f (blob-ref ob p)))
            (loop (- i 1) p))
          (make-byte-blob ob1 0)))))
    

(define (byte-blob-fold-right f init b)
  (let* ((blen  (byte-blob-size b))
         (ob    (byte-blob-object b)))
    (let loop ((i blen) (p (+ blen (byte-blob-offset b))) (ax init))
      (if (positive? i) 
          (let ((p (- p 1)))
            (loop (- i 1) p (f (blob-ref ob p) ax)))
          ax))))

    
(define (byte-blob-fold-left f init b)
  (let* ((blen  (byte-blob-size b))
         (ob    (byte-blob-object b)))
    (let loop ((i blen) (p (byte-blob-offset b))
               (ax init))
      (if (positive? i) 
          (loop (- i 1) (+ 1 p) (f (blob-ref ob p) ax))
          ax))))
    
        
(define (byte-blob->list b)
  (let loop ((b b) (ax '()))
    (cond ((byte-blob-empty? b) (reverse ax))
          (else  (loop (byte-blob-cdr b) (cons (byte-blob-car b) ax))))))
         
(define (byte-blob->string b)
  (blob->string (byte-blob-object b)))



;; The following three functions are borrowed from the
;; Chicken-specific parts of SWIG
#>
static void chicken_Panic (C_char *) C_noret;
static void chicken_Panic (C_char *msg)
{
  C_word *a = C_alloc (C_SIZEOF_STRING (strlen (msg)));
  C_word scmmsg = C_string2 (&a, msg);
  C_halt (scmmsg);
  exit (5); /* should never get here */
}

static void chicken_ThrowException(C_word value) C_noret;
static void chicken_ThrowException(C_word value)
{
  char *aborthook = C_text("\003sysabort");

  C_word *a = C_alloc(C_SIZEOF_STRING(strlen(aborthook)));
  C_word abort = C_intern2(&a, aborthook);

  abort = C_block_item(abort, 0);
  if (C_immediatep(abort))
    Chicken_Panic(C_text("`##sys#abort' is not defined"));

  C_save(value);
  C_do_apply(1, abort, C_SCHEME_UNDEFINED);
}

void chicken_io_exception (int code, int msglen, const char *msg) 
{
  C_word *a;
  C_word scmmsg;
  C_word list;

  a = C_alloc (C_SIZEOF_STRING (msglen) + C_SIZEOF_LIST(2));
  scmmsg = C_string2 (&a, (char *) msg);
  list = C_list(&a, 2, C_fix(code), scmmsg);
  chicken_ThrowException(list);
}

<#



(define blob-read
    (foreign-lambda* unsigned-int ((integer fd) (nonnull-blob b) (integer n) )
#<<END
     ssize_t s;

     if ( (s = read(fd,b,n)) == -1 )
     {
          chicken_io_exception (-1,32,"read I/O error in byte-blob-read");
     }
     if (s == 0) chicken_io_exception (-1,32,"EOF reached in byte-blob-read");

     C_return(s);
END
))


(define (byte-blob-read port n)
  (let ((ob (make-blob n)))
    (blob-read (port->fileno port) ob n)
    (make-byte-blob ob 0)))


(define blob-write
    (foreign-lambda* void ((integer fd) (nonnull-blob b) (integer size) (integer offset))
#<<END
     ssize_t s,n;

     n = s = 0; 
     while (n < size)
     {
          if ( (s = write(fd,(const void *)(b+n+offset),size-n)) == -1 )
          {
               chicken_io_exception (-1,32,"write I/O error in byte-blob-write");
               return -1;
          }
          n += s;
     }
     C_return(C_SCHEME_UNDEFINED);
END
))

(define (byte-blob-write port b)
  (let ((ob (byte-blob-object b))
        (n  (byte-blob-size b))
        (offset (byte-blob-offset b)))
    (blob-write (port->fileno port) ob n offset)))



)