specops/checksum.lisp at master · phantomics/specops · GitHub

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
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
;;;; checksum.lisp

(in-package #:specops)

;;;; table-driven crc32 implementation, after rfc1952
;;;
;;; This runs with very little consing in CMUCL.
;;;
;;; Written by R. Matthew Emerson <rme@acm.org> in August 1999,
;;; and placed in the public domain.

#|
;;; initial-contents of *crc-table* were computed with this function:
(defconstant *crc-polynomial* #xedb88320)
(defun make-crc-table ()
  (dotimes (i 256)
    (let ((c i))
      (dotimes (k 8)
	(if (= 1 (logand c 1))
	    (setf c (logxor (ash c -1) *crc-polynomial*))
	    (setf c (ash c -1))))
      (if (zerop (mod i 6)) (terpri))
      (format t "#x~8,'0x " c))))
|#

(defconstant +crc-table+
  (make-array
   256
   :element-type '(unsigned-byte 32)
   :initial-contents
   '(#x00000000 #x77073096 #xEE0E612C #x990951BA #x076DC419 #x706AF48F
     #xE963A535 #x9E6495A3 #x0EDB8832 #x79DCB8A4 #xE0D5E91E #x97D2D988
     #x09B64C2B #x7EB17CBD #xE7B82D07 #x90BF1D91 #x1DB71064 #x6AB020F2
     #xF3B97148 #x84BE41DE #x1ADAD47D #x6DDDE4EB #xF4D4B551 #x83D385C7
     #x136C9856 #x646BA8C0 #xFD62F97A #x8A65C9EC #x14015C4F #x63066CD9
     #xFA0F3D63 #x8D080DF5 #x3B6E20C8 #x4C69105E #xD56041E4 #xA2677172
     #x3C03E4D1 #x4B04D447 #xD20D85FD #xA50AB56B #x35B5A8FA #x42B2986C
     #xDBBBC9D6 #xACBCF940 #x32D86CE3 #x45DF5C75 #xDCD60DCF #xABD13D59
     #x26D930AC #x51DE003A #xC8D75180 #xBFD06116 #x21B4F4B5 #x56B3C423
     #xCFBA9599 #xB8BDA50F #x2802B89E #x5F058808 #xC60CD9B2 #xB10BE924
     #x2F6F7C87 #x58684C11 #xC1611DAB #xB6662D3D #x76DC4190 #x01DB7106
     #x98D220BC #xEFD5102A #x71B18589 #x06B6B51F #x9FBFE4A5 #xE8B8D433
     #x7807C9A2 #x0F00F934 #x9609A88E #xE10E9818 #x7F6A0DBB #x086D3D2D
     #x91646C97 #xE6635C01 #x6B6B51F4 #x1C6C6162 #x856530D8 #xF262004E
     #x6C0695ED #x1B01A57B #x8208F4C1 #xF50FC457 #x65B0D9C6 #x12B7E950
     #x8BBEB8EA #xFCB9887C #x62DD1DDF #x15DA2D49 #x8CD37CF3 #xFBD44C65
     #x4DB26158 #x3AB551CE #xA3BC0074 #xD4BB30E2 #x4ADFA541 #x3DD895D7
     #xA4D1C46D #xD3D6F4FB #x4369E96A #x346ED9FC #xAD678846 #xDA60B8D0
     #x44042D73 #x33031DE5 #xAA0A4C5F #xDD0D7CC9 #x5005713C #x270241AA
     #xBE0B1010 #xC90C2086 #x5768B525 #x206F85B3 #xB966D409 #xCE61E49F
     #x5EDEF90E #x29D9C998 #xB0D09822 #xC7D7A8B4 #x59B33D17 #x2EB40D81
     #xB7BD5C3B #xC0BA6CAD #xEDB88320 #x9ABFB3B6 #x03B6E20C #x74B1D29A
     #xEAD54739 #x9DD277AF #x04DB2615 #x73DC1683 #xE3630B12 #x94643B84
     #x0D6D6A3E #x7A6A5AA8 #xE40ECF0B #x9309FF9D #x0A00AE27 #x7D079EB1
     #xF00F9344 #x8708A3D2 #x1E01F268 #x6906C2FE #xF762575D #x806567CB
     #x196C3671 #x6E6B06E7 #xFED41B76 #x89D32BE0 #x10DA7A5A #x67DD4ACC
     #xF9B9DF6F #x8EBEEFF9 #x17B7BE43 #x60B08ED5 #xD6D6A3E8 #xA1D1937E
     #x38D8C2C4 #x4FDFF252 #xD1BB67F1 #xA6BC5767 #x3FB506DD #x48B2364B
     #xD80D2BDA #xAF0A1B4C #x36034AF6 #x41047A60 #xDF60EFC3 #xA867DF55
     #x316E8EEF #x4669BE79 #xCB61B38C #xBC66831A #x256FD2A0 #x5268E236
     #xCC0C7795 #xBB0B4703 #x220216B9 #x5505262F #xC5BA3BBE #xB2BD0B28
     #x2BB45A92 #x5CB36A04 #xC2D7FFA7 #xB5D0CF31 #x2CD99E8B #x5BDEAE1D
     #x9B64C2B0 #xEC63F226 #x756AA39C #x026D930A #x9C0906A9 #xEB0E363F
     #x72076785 #x05005713 #x95BF4A82 #xE2B87A14 #x7BB12BAE #x0CB61B38
     #x92D28E9B #xE5D5BE0D #x7CDCEFB7 #x0BDBDF21 #x86D3D2D4 #xF1D4E242
     #x68DDB3F8 #x1FDA836E #x81BE16CD #xF6B9265B #x6FB077E1 #x18B74777
     #x88085AE6 #xFF0F6A70 #x66063BCA #x11010B5C #x8F659EFF #xF862AE69
     #x616BFFD3 #x166CCF45 #xA00AE278 #xD70DD2EE #x4E048354 #x3903B3C2
     #xA7672661 #xD06016F7 #x4969474D #x3E6E77DB #xAED16A4A #xD9D65ADC
     #x40DF0B66 #x37D83BF0 #xA9BCAE53 #xDEBB9EC5 #x47B2CF7F #x30B5FFE9
     #xBDBDF21C #xCABAC28A #x53B39330 #x24B4A3A6 #xBAD03605 #xCDD70693
     #x54DE5729 #x23D967BF #xB3667A2E #xC4614AB8 #x5D681B02 #x2A6F2B94
     #xB40BBE37 #xC30C8EA1 #x5A05DF1B #x2D02EF8D)))

(defun update-crc2 (crc buf)
  (declare (type (unsigned-byte 32) crc)
	   (type (simple-array (unsigned-byte 8)) buf)
	   (optimize speed))
  (setf crc (logxor crc #xffffffff))
  (dotimes (n (length buf))
    (let ((i (logand #xff (logxor crc (aref buf n)))))
      (setf crc (logxor (aref +crc-table+ i) (ash crc -8)))))
  (logxor crc #xffffffff))

(defun crc2 (buf)
  (update-crc 0 buf))

(defun update-crc (crc buf start end)
  (declare (type (unsigned-byte 32) crc)
	   (type (simple-array (unsigned-byte 8)) buf)
	   (optimize speed))
  (let ((index start))
    (setf crc (logxor crc #xffffffff))
    (dotimes (n (- end start))
      (let ((i (logand #xff (logxor crc (aref buf index)))))
        (setf crc (logxor (aref +crc-table+ i) (ash crc -8)))
        (incf index)))
    (logxor crc #xffffffff)))

(defun crc (buf start end)
  (update-crc 0 buf start end))

;;; output should be #xCBF43926
(defun test-crc ()
  (let ((a (make-array 9 :element-type '(unsigned-byte 8)
		       :initial-contents '(#x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38 #x39))))
    (crc2 a)))

;;;; Adapted from adler32.lisp - computing adler32 checksums (rfc1950) of a byte array
;;;
;;; Author: Nathan Froyd <froydnj@cs.rice.edu>, BSD license
;;;
;;; This implementation should work with minimal consing on all
;;; Common Lisp implementations with reasonable implementations of fixnums.

;;; smallest prime < 65536
(defconstant adler32-modulo 65521)

(defstruct adler32
  (s1 1 :type fixnum)
  (s2 0 :type fixnum)
  (length 0 :type fixnum))

(defun update-adler32 (adler32 vector &key (start 0) (end (length vector)))
  "Update the internal state of ADLER32 with the elements of VECTOR
bounded by START and END.  VECTOR should contain elements of either
type BASE-CHAR or of type (UNSIGNED-BYTE 8)."
  (declare (type adler32 adler32))
  #+sbcl (declare (type sb-int:index start end))
  (declare (optimize (speed 3) (safety 1) (space 0)))
  (let ((s1 (adler32-s1 adler32))
        (s2 (adler32-s2 adler32))
        (length (adler32-length adler32)))
    (declare (type fixnum s1 s2 length))
    (flet ((frob-buffer (frob-fun buffer start end)
             ;; This loop could be unrolled for better performance.
             (do ((i start (1+ i)))
                 ((= i end)
                  (setf (adler32-s1 adler32) (logand s1 #xffff)
                        (adler32-s2 adler32) (logand s2 #xffff)
                        (adler32-length adler32) length)
                  adler32)
               (setf s1 (+ s1 (funcall frob-fun (aref buffer i)))
                     s2 (+ s2 s1))
               (incf length)
               (when (= length 5552)
                 (setf s1 (truncate s1 adler32-modulo)
                       s2 (truncate s2 adler32-modulo)
                       length 0)))))
      (declare (inline frob-buffer))
      (etypecase vector
        ((simple-array (unsigned-byte 8) (*))
         (locally
             (declare (type (simple-array (unsigned-byte 8) (*)) vector))
           (frob-buffer #'identity vector start end)))
        (simple-base-string
         (locally
             (declare (type simple-base-string vector))
           (frob-buffer #'char-code vector start end)))))))


(defun finalize-adler32 (adler32)
  "Return the final 32-bit checksum stored in ADLER32."
  (logior (ash (adler32-s2 adler32) 16)
          (adler32-s1 adler32)))

(defun adler32-checksum (sequence &key (start 0) (end (length sequence)))
  "Compute the adler32 checksum of SEQUENCE bounded by START and END.
On CMU CL and SBCL, this function works for all array-based sequences
whose element-type is supported by UPDATE-ADLER32.  On other implementations,
this function will only work for 1d simple-arrays with such element-types."
  (declare (type vector sequence))
  (let ((adler32 (make-adler32)))
    #+cmu
    (lisp::with-array-data ((buffer sequence) (start start) (end end))
      (update-adler32 adler32 buffer :start start :end end))
    #+sbcl
    (sb-kernel:with-array-data ((buffer sequence) (start start) (end end))
      (update-adler32 adler32 buffer :start start :end end))
    #-(or cmu sbcl)
    (update-adler32 adler32 sequence :start start :end end)
    (finalize-adler32 adler32)))