crc32.sls

#!r6rs

(library (crc32)
  (export crc32)
  (import (rnrs)
          (rnrs arithmetic bitwise (6)))

(define (crc32 data . opt)
  (let ((r (get-optional opt #xFFFFFFFF))
        (len (bytevector-length data))
        (ind #f))
    (let loop ((i 0)
               (rl (bitwise-and r #xFFFF))
               (rh (bitwise-arithmetic-shift-right r 16)))
      (if (= i len)
          (bitwise-xor
           #xFFFFFFFF
           (bitwise-ior rl (bitwise-arithmetic-shift rh 16)))
          (begin
            (set! ind (fxxor (fxand rl #xFF) (bytevector-u8-ref data i)))
            (loop
             (+ i 1)
             (fxxor (fxior (fxarithmetic-shift-right rl 8)
                           (fxarithmetic-shift (fxand rh #xFF) 8))
                    (vector-ref table-low ind))
             (fxxor (fxarithmetic-shift-right rh 8)
                    (vector-ref table-high ind))))))))

(define (get-optional rest default)
  (if (pair? rest) (car rest) default))

(let-syntax
    ((make-crc-table
      (lambda(stx)

(define CRCPOLY32 #xedb88320)

(define (make-crc-table poly)
  (let ((table (make-vector 256)))
    (do ((i 0 (+ i 1)))
        ((= i 256))
      (vector-set! table i
                   (do ((j 0 (+ j 1))
                        (r i
                           ((if (zero? (bitwise-and r 1))
                                values
                                (lambda(x) (bitwise-xor poly x)))
                            (bitwise-arithmetic-shift-right r 1))))
                       ((= j 8) r))))
    table))

(define (low x) (bitwise-and x #xFFFF))

(define (high x) (bitwise-arithmetic-shift-right x 16))

(syntax-case stx ()
  ((k table-low table-high)
   (let ((table (make-crc-table CRCPOLY32)))
     #`(begin
         (define table-low (quote #,(vector-map low table)))
         (define table-high (quote #,(vector-map high table)))))))
)))

(make-crc-table table-low table-high)
)
)