crc32.lisp

   1 ;;;; $Id: crc32.lisp,v 1.2 2007/12/19 20:53:26 xach Exp $
   2
   3 (in-package #:salza2)
   4
   5 (defun crc32-table ()
   6   (let ((table (make-array 512 :element-type '(unsigned-byte 16))))
   7     (dotimes (n 256 table)
   8       (let ((c n))
   9         (declare (type (unsigned-byte 32) c))
  10         (dotimes (k 8)
  11           (if (logbitp 0 c)
  12               (setf c (logxor #xEDB88320 (ash c -1)))
  13               (setf c (ash c -1)))
  14           (setf (aref table (ash n 1)) (ldb (byte 16 16) c)
  15                 (aref table (1+ (ash n 1))) (ldb (byte 16 0) c)))))))
  16
  17 (defun crc32 (high low buf start count)
  18   (declare (type (unsigned-byte 16) high low)
  19            (type (integer 0 32768) count)
  20            (type octet-vector buf)
  21            (optimize speed))
  22   (let ((i start)
  23         (table *crc32-table*))
  24     (declare (type (integer 0 65536) i)
  25              (type (simple-array (unsigned-byte 16) (*)) table))
  26     (dotimes (j count (values high low))
  27       (let ((index (logxor (logand low #xFF) (aref buf i))))
  28         (declare (type (integer 0 255) index))
  29         (let ((high-index (ash index 1))
  30               (low-index (1+ (ash index 1))))
  31           (declare (type (integer 0 511) high-index low-index))
  32           (let ((t-high (aref table high-index))
  33                 (t-low (aref table low-index)))
  34             (declare (type (unsigned-byte 16) t-high t-low))
  35             (incf i)
  36             (setf low (logxor (ash (logand high #xFF) 8)
  37                               (ash low -8)
  38                               t-low))
  39             (setf high (logxor (ash high -8) t-high))))))))
  40
  41 ;;; Class interface
  42
  43 (defclass crc32-checksum (checksum)
  44   ((low
  45     :initarg :low
  46     :accessor low)
  47    (high
  48     :initarg :high
  49     :accessor high))
  50   (:default-initargs
  51    :low #xFFFF
  52    :high #xFFFF))
  53
  54 (defmethod update ((checksum crc32-checksum) input start count)
  55   (setf (values (high checksum)
  56                 (low checksum))
  57         (salza2::crc32 (high checksum) (low checksum)
  58                        input start count)))
  59
  60 (defmethod result ((checksum crc32-checksum))
  61   (+ (ash (logxor (high checksum) #xFFFF) 16)
  62      (logxor (low checksum) #xFFFF)))
  63
  64 (defmethod result-octets ((checksum crc32-checksum))
  65   (ub32-octets (result checksum)))