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

KindCoveredAll%
expression0180 0.0
branch02 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;;; md2.lisp -- the MD2 message digest algorithm from RFC 1319
2
 (in-package :crypto)
3
 (in-ironclad-readtable)
4
 
5
 (defconst +md2-permutation+
6
   #8@(41 46 67 201 162 216 124 1 61 54 84 161 236 240 6
7
          19 98 167 5 243 192 199 115 140 152 147 43 217 188
8
          76 130 202 30 155 87 60 253 212 224 22 103 66 111 24
9
          138 23 229 18 190 78 196 214 218 158 222 73 160 251
10
          245 142 187 47 238 122 169 104 121 145 21 178 7 63
11
          148 194 16 137 11 34 95 33 128 127 93 154 90 144 50
12
          39 53 62 204 231 191 247 151 3 255 25 48 179 72 165
13
          181 209 215 94 146 42 172 86 170 198 79 184 56 210
14
          150 164 125 182 118 252 107 226 156 116 4 241 69 157
15
          112 89 100 113 135 32 134 91 207 101 230 45 168 2 27
16
          96 37 173 174 176 185 246 28 70 97 105 52 64 126 15
17
          85 71 163 35 221 81 175 58 195 92 249 206 186 197
18
          234 38 44 83 13 110 133 40 132 9 211 223 205 244 65
19
          129 77 82 106 220 55 200 108 193 171 250 36 225 123
20
          8 12 189 177 74 120 136 149 139 227 99 232 109 233
21
          203 213 254 59 0 29 57 242 239 183 14 102 88 208 228
22
          166 119 114 248 235 117 75 10 49 68 80 180 143 237
23
          31 26 219 153 141 51 159 17 131 20))
24
 
25
 (eval-when (:compile-toplevel)
26
   (defmacro stateref (regs i) `(aref ,regs (+ ,i 0)))
27
   (defmacro blockref (regs i) `(aref ,regs (+ ,i 16)))
28
   (defmacro workref (regs i) `(aref ,regs (+ ,i 32)))) ; EVAL-WHEN
29
 
30
 (defun update-md2-regs (regs buffer offset checksum)
31
   (declare (type (simple-array (unsigned-byte 8) (48)) regs)
32
            (type (simple-array (unsigned-byte 8) (16)) checksum)
33
            (type simple-octet-vector buffer)
34
            #.(burn-baby-burn))
35
   (let ((x 0))
36
     (declare (type (unsigned-byte 8) x))
37
     ;; save original input and prepare encryption block
38
     (dotimes (i 16)
39
       (setf (workref regs i)
40
             (logxor (stateref regs i) (aref buffer (+ i offset)))
41
             (blockref regs i) (aref buffer (+ i offset))))
42
     ;; encrypt block
43
     (dotimes (i 18)
44
       (dotimes (j 48)
45
         (setf x (logxor (aref +md2-permutation+ x) (aref regs j))
46
               (aref regs j) x))
47
       (setf x (mod (+ x i) 256)))
48
     ;; update checksum
49
     (setf x (aref checksum 15))
50
     (dotimes (i 16)
51
       (setf x (logxor (aref checksum i)
52
                       (aref +md2-permutation+
53
                             (logxor (aref buffer (+ i offset)) x)))
54
             (aref checksum i) x))))
55
 
56
 (declaim (inline md2-regs-digest))
57
 (defun md2-regs-digest (regs buffer start)
58
   (declare (type (simple-array (unsigned-byte 8) (48)) regs)
59
            #.(burn-baby-burn))
60
   (flet ((stuff-registers (buffer start)
61
            (declare (type (simple-array (unsigned-byte 8) (*)) buffer))
62
            (dotimes (i 16 buffer)
63
              (setf (aref buffer (+ start i)) (stateref regs i)))))
64
     (declare (inline stuff-registers))
65
     (cond
66
       (buffer
67
        (stuff-registers buffer start))
68
       (t
69
        (stuff-registers (make-array 16 :element-type '(unsigned-byte 8)
70
                                        :initial-element 0) 0)))))
71
 
72
 (defstruct (md2
73
             (:constructor %make-md2-digest
74
                 (&aux (buffer (make-array 16 :element-type '(unsigned-byte 8)
75
                                              :initial-element 0))))
76
             (:constructor %make-md2-state
77
                 (regs checksum buffer buffer-index))
78
             (:copier nil)
79
             (:include mdx))
80
   (regs (make-array 48 :element-type '(unsigned-byte 8) :initial-element 0)
81
    :type (simple-array (unsigned-byte 8) (48)) :read-only t)
82
   (checksum (make-array 16 :element-type '(unsigned-byte 8) :initial-element 0)
83
    :type (simple-array (unsigned-byte 8) (16)) :read-only t))
84
 
85
 (defmethod reinitialize-instance ((state md2) &rest initargs)
86
   (declare (ignore initargs))
87
   (fill (md2-regs state) 0)
88
   (fill (md2-checksum state) 0)
89
   (setf (md2-buffer-index state) 0)
90
   state)
91
 
92
 (defmethod copy-digest ((state md2) &optional copy)
93
   (check-type copy (or null md2))
94
   (cond
95
     (copy
96
      (replace (md2-regs copy) (md2-regs state))
97
      (replace (md2-checksum copy) (md2-checksum state))
98
      (replace (md2-buffer copy) (md2-buffer state))
99
      (setf (md2-buffer-index copy) (md2-buffer-index state))
100
      copy)
101
     (t
102
      (%make-md2-state (copy-seq (md2-regs state))
103
                       (copy-seq (md2-checksum state))
104
                       (copy-seq (md2-buffer state))
105
                       (md2-buffer-index state)))))
106
 
107
 (define-digest-updater md2
108
   (flet ((compress (state sequence offset)
109
            (update-md2-regs (md2-regs state)
110
                             sequence offset
111
                             (md2-checksum state))))
112
     (declare (dynamic-extent #'compress))
113
     (declare (notinline mdx-updater))
114
     (mdx-updater state #'compress sequence start end)))
115
 
116
 (define-digest-finalizer (md2 16)
117
   (let* ((regs (md2-regs state))
118
          (checksum (md2-checksum state))
119
          (buffer (md2-buffer state))
120
          (buffer-index (md2-buffer-index state))
121
          (pad-amount (- 16 buffer-index)))
122
     ;; pad with appropriate padding
123
     (dotimes (i pad-amount)
124
       (setf (aref buffer (+ buffer-index i)) pad-amount))
125
     (update-md2-regs regs buffer 0 checksum)
126
     ;; extend the message with the checksum
127
     (dotimes (i 16)
128
       (setf (aref buffer i) (aref checksum i)))
129
     (update-md2-regs regs buffer 0 checksum)
130
     (finalize-registers state regs)))
131
 
132
 (defdigest md2 :digest-length 16 :block-length 16)