Coverage report: /home/ellis/comp/ext/ironclad/src/digests/adler32.lisp

KindCoveredAll%
expression074 0.0
branch06 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;; adler32.lisp - computing adler32 checksums (rfc1950) of a byte array
2
 (in-package :crypto)
3
 
4
 ;;; smallest prime < 65536
5
 (defconstant adler32-modulo 65521)
6
 
7
 (defstruct (adler32
8
              (:constructor %make-adler32-digest nil)
9
              (:constructor %make-adler32-state (s1 s2))
10
              (:copier nil))
11
   (s1 1 :type fixnum)
12
   (s2 0 :type fixnum))
13
 
14
 (defmethod reinitialize-instance ((state adler32) &rest initargs)
15
   (declare (ignore initargs))
16
   (setf (adler32-s1 state) 1
17
         (adler32-s2 state) 0)
18
   state)
19
 
20
 (defmethod copy-digest ((state adler32) &optional copy)
21
   (check-type copy (or null adler32))
22
   (cond
23
     (copy
24
      (setf (adler32-s1 copy) (adler32-s1 state)
25
            (adler32-s2 copy) (adler32-s2 copy))
26
      copy)
27
     (t
28
      (%make-adler32-state (adler32-s1 state) (adler32-s2 state)))))
29
 
30
 (define-digest-updater adler32
31
   ;; many thanks to Xach for his code from Salza.
32
   (let ((length (- end start))
33
         (i 0)
34
         (k 0)
35
         (s1 (adler32-s1 state))
36
         (s2 (adler32-s2 state)))
37
     (declare (type index i k length)
38
              (type fixnum s1 s2))
39
     (unless (zerop length)
40
       (tagbody
41
        loop
42
          (setf k (min 16 length))
43
          (decf length k)
44
        sum
45
          (setf s1 (+ (aref sequence (+ start i)) s1))
46
          (setf s2 (+ s1 s2))
47
          (decf k)
48
          (incf i)
49
          (unless (zerop k)
50
            (go sum))
51
          (setf s1 (mod s1 adler32-modulo))
52
          (setf s2 (mod s2 adler32-modulo))
53
          (unless (zerop length)
54
            (go loop))
55
          (setf (adler32-s1 state) s1
56
                (adler32-s2 state) s2)))
57
     state))
58
 
59
 (define-digest-finalizer (adler32 4)
60
   (flet ((stuff-state (state digest start)
61
            (declare (type (simple-array (unsigned-byte 8) (*)) digest))
62
            (declare (type (integer 0 #.(- array-dimension-limit 4)) start))
63
            (setf (ub32ref/be digest start)
64
                  (logior (ash (adler32-s2 state) 16)
65
                          (adler32-s1 state)))
66
            digest))
67
     (declare (inline stuff-state))
68
     (stuff-state state digest digest-start)))
69
 
70
 (defdigest adler32 :digest-length 4 :block-length 1)