/usr/share/common-lisp/source/chipz/crc32.lisp is in cl-chipz 20130128-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 | ;;;; crc32.lisp -- implementation of the CRC32 checksum
(in-package :chipz)
#+sbcl
(progn
(defstruct (crc32
(:copier copy-crc32))
(crc #xffffffff :type (unsigned-byte 32)))
(defun update-crc32 (state vector start end)
(declare (type simple-octet-vector vector))
(declare (type index start end))
(do ((crc (crc32-crc state))
(i start (1+ i))
(table +crc32-table+))
((>= i end)
(setf (crc32-crc state) crc)
state)
(declare (type (unsigned-byte 32) crc))
(setf crc (logxor (aref table
(logand (logxor crc (aref vector i)) #xff))
(ash crc -8)))))
(defun produce-crc32 (state)
(logxor #xffffffff (crc32-crc state)))
)
;; An implementation that conses significantly less on most
;; implementations. Credit to Zach Beane.
#-sbcl
(progn
(defstruct (crc32
(:copier copy-crc32))
(low #xffff)
(high #xffff))
(defun crc32-table ()
(let ((table (make-array 512 :element-type '(unsigned-byte 16))))
(dotimes (n 256 table)
(let ((c n))
(declare (type (unsigned-byte 32) c))
(dotimes (k 8)
(if (logbitp 0 c)
(setf c (logxor #xEDB88320 (ash c -1)))
(setf c (ash c -1)))
(setf (aref table (ash n 1)) (ldb (byte 16 16) c)
(aref table (1+ (ash n 1))) (ldb (byte 16 0) c)))))))
(defvar *crc32-table* (crc32-table))
(defun crc32 (high low buf start count)
(declare (type (unsigned-byte 16) high low)
(type index start count)
(type simple-octet-vector buf)
(optimize speed))
(let ((i start)
(table *crc32-table*))
(declare (type index i)
(type (simple-array (unsigned-byte 16) (*)) table))
(dotimes (j count (values high low))
(let ((index (logxor (logand low #xFF) (aref buf i))))
(declare (type (integer 0 255) index))
(let ((high-index (ash index 1))
(low-index (1+ (ash index 1))))
(declare (type (integer 0 511) high-index low-index))
(let ((t-high (aref table high-index))
(t-low (aref table low-index)))
(declare (type (unsigned-byte 16) t-high t-low))
(incf i)
(setf low (logxor (ash (logand high #xFF) 8)
(ash low -8)
t-low))
(setf high (logxor (ash high -8) t-high))))))))
(defun update-crc32 (state vector start end)
;; ABCL used to miscompile (SETF (VALUES (ACCESSOR ...) ...) ...)
;; in case you were wondering why we take this route.
(multiple-value-bind (high low) (crc32 (crc32-high state) (crc32-low state)
vector start (- end start))
(setf (crc32-high state) high
(crc32-low state) low)
(values high low)))
(defun produce-crc32 (state)
(+ (ash (logxor (crc32-high state) #xFFFF) 16)
(logxor (crc32-low state) #xFFFF)))
)
|