File: adler32.lisp

package info (click to toggle)
cl-chipz 20160318-1
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 260 kB
  • sloc: lisp: 2,515; makefile: 13
file content (44 lines) | stat: -rw-r--r-- 1,220 bytes parent folder | download | duplicates (3)
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
;;; adler32.lisp -- computing adler32 checksums (rfc1950)

(in-package :chipz)

(defstruct (adler32
             (:copier copy-adler32))
  (s1 1 :type fixnum)
  (s2 0 :type fixnum))

(defun update-adler32 (state vector start end)
  (declare (type simple-octet-vector vector))
  (declare (type index start end))
  ;; many thanks to Xach for his code from Salza.
  (let ((length (- end start))
        (i 0)
        (k 0)
        (s1 (adler32-s1 state))
        (s2 (adler32-s2 state)))
    (declare (type index i k length)
             (type fixnum s1 s2))
    (unless (zerop length)
      (tagbody
       loop
         (setf k (min 16 length))
         (decf length k)
       sum
         (setf s1 (+ (aref vector (+ start i)) s1))
         (setf s2 (+ s1 s2))
         (decf k)
         (incf i)
         (unless (zerop k)
           (go sum))
         (setf s1 (mod s1 adler32-modulo))
         (setf s2 (mod s2 adler32-modulo))
         (unless (zerop length)
           (go loop))
       end
         (setf (adler32-s1 state) s1
               (adler32-s2 state) s2)
         (return-from update-adler32 state)))))

(defun produce-adler32 (state)
  (logior (ash (adler32-s2 state) 16)
          (adler32-s1 state)))