| blob | 3e00ceb2214cbd2b8ed931e8016aa8338aac37ff |
1 ;;;============================================================================
3 ;;; File: "digest.scm", Time-stamp: <2009-02-19 23:38:26 feeley>
5 ;;; Copyright (c) 2005-2009 by Marc Feeley, All Rights Reserved.
7 ;;;============================================================================
9 ;;; Contains procedures to compute message digests.
11 (##namespace ("digest#"))
12 (##include "~~lib/gambit#.scm")
14 (declare
15 (standard-bindings)
16 (extended-bindings)
17 (not inline)
18 (not safe))
20 (define-macro (fx+ . args) `(##fx+ ,@args))
21 (define-macro (fx- . args) `(##fx- ,@args))
22 (define-macro (fx* . args) `(##fx* ,@args))
23 (define-macro (fxquotient . args) `(##fxquotient ,@args))
24 (define-macro (fxmin . args) `(##fxmin ,@args))
25 (define-macro (fx= . args) `(##fx= ,@args))
26 (define-macro (fx< . args) `(##fx< ,@args))
27 (define-macro (fx> . args) `(##fx> ,@args))
28 (define-macro (fx<= . args) `(##fx<= ,@args))
29 (define-macro (fx>= . args) `(##fx>= ,@args))
30 (define-macro (fxnot . args) `(##fxnot ,@args))
31 (define-macro (fxand . args) `(##fxand ,@args))
32 (define-macro (fxior . args) `(##fxior ,@args))
33 (define-macro (fxxor . args) `(##fxxor ,@args))
34 (define-macro (fxarithmetic-shift-right . args) `(##fxarithmetic-shift-right ,@args))
35 (define-macro (fxarithmetic-shift-left . args) `(##fxarithmetic-shift-left ,@args))
36 (define-macro (make-vector . args) `(##make-vector ,@args))
37 (define-macro (make-u8vector . args) `(##make-u8vector ,@args))
38 (define-macro (u8vector . args) `(##u8vector ,@args))
39 (define-macro (u8vector-length . args) `(##u8vector-length ,@args))
40 (define-macro (u8vector-ref . args) `(##u8vector-ref ,@args))
41 (define-macro (u8vector-set! . args) `(##u8vector-set! ,@args))
42 (define-macro (read-subu8vector . args) `(##read-subu8vector ,@args))
43 (define-macro (string-append . args) `(##string-append ,@args))
44 (define-macro (make-string . args) `(##make-string ,@args))
45 (define-macro (open-input-file . args) `(##open-input-file ,@args))
46 (define-macro (close-input-port . args) `(##close-input-port ,@args))
47 (define-macro (number->string . args) `(##number->string ,@args))
49 ;;;----------------------------------------------------------------------------
51 (define-type digest
52 id: digest-f65996cb-c1aa-4ee9-86cd-1af55b5ddb74
53 end
54 update
55 state)
57 ;;;----------------------------------------------------------------------------
59 ;; CRC32 digest.
61 (define-type crc32-digest
62 id: crc32-digest-f65996cb-c1aa-4ee9-86cd-1af55b5ddb74
63 hi16
64 lo16)
66 (define crc32-table '#(
67 #x0000 #x0000 #x7707 #x3096 #xEE0E #x612C #x9909 #x51BA
68 #x076D #xC419 #x706A #xF48F #xE963 #xA535 #x9E64 #x95A3
69 #x0EDB #x8832 #x79DC #xB8A4 #xE0D5 #xE91E #x97D2 #xD988
70 #x09B6 #x4C2B #x7EB1 #x7CBD #xE7B8 #x2D07 #x90BF #x1D91
71 #x1DB7 #x1064 #x6AB0 #x20F2 #xF3B9 #x7148 #x84BE #x41DE
72 #x1ADA #xD47D #x6DDD #xE4EB #xF4D4 #xB551 #x83D3 #x85C7
73 #x136C #x9856 #x646B #xA8C0 #xFD62 #xF97A #x8A65 #xC9EC
74 #x1401 #x5C4F #x6306 #x6CD9 #xFA0F #x3D63 #x8D08 #x0DF5
75 #x3B6E #x20C8 #x4C69 #x105E #xD560 #x41E4 #xA267 #x7172
76 #x3C03 #xE4D1 #x4B04 #xD447 #xD20D #x85FD #xA50A #xB56B
77 #x35B5 #xA8FA #x42B2 #x986C #xDBBB #xC9D6 #xACBC #xF940
78 #x32D8 #x6CE3 #x45DF #x5C75 #xDCD6 #x0DCF #xABD1 #x3D59
79 #x26D9 #x30AC #x51DE #x003A #xC8D7 #x5180 #xBFD0 #x6116
80 #x21B4 #xF4B5 #x56B3 #xC423 #xCFBA #x9599 #xB8BD #xA50F
81 #x2802 #xB89E #x5F05 #x8808 #xC60C #xD9B2 #xB10B #xE924
82 #x2F6F #x7C87 #x5868 #x4C11 #xC161 #x1DAB #xB666 #x2D3D
83 #x76DC #x4190 #x01DB #x7106 #x98D2 #x20BC #xEFD5 #x102A
84 #x71B1 #x8589 #x06B6 #xB51F #x9FBF #xE4A5 #xE8B8 #xD433
85 #x7807 #xC9A2 #x0F00 #xF934 #x9609 #xA88E #xE10E #x9818
86 #x7F6A #x0DBB #x086D #x3D2D #x9164 #x6C97 #xE663 #x5C01
87 #x6B6B #x51F4 #x1C6C #x6162 #x8565 #x30D8 #xF262 #x004E
88 #x6C06 #x95ED #x1B01 #xA57B #x8208 #xF4C1 #xF50F #xC457
89 #x65B0 #xD9C6 #x12B7 #xE950 #x8BBE #xB8EA #xFCB9 #x887C
90 #x62DD #x1DDF #x15DA #x2D49 #x8CD3 #x7CF3 #xFBD4 #x4C65
91 #x4DB2 #x6158 #x3AB5 #x51CE #xA3BC #x0074 #xD4BB #x30E2
92 #x4ADF #xA541 #x3DD8 #x95D7 #xA4D1 #xC46D #xD3D6 #xF4FB
93 #x4369 #xE96A #x346E #xD9FC #xAD67 #x8846 #xDA60 #xB8D0
94 #x4404 #x2D73 #x3303 #x1DE5 #xAA0A #x4C5F #xDD0D #x7CC9
95 #x5005 #x713C #x2702 #x41AA #xBE0B #x1010 #xC90C #x2086
96 #x5768 #xB525 #x206F #x85B3 #xB966 #xD409 #xCE61 #xE49F
97 #x5EDE #xF90E #x29D9 #xC998 #xB0D0 #x9822 #xC7D7 #xA8B4
98 #x59B3 #x3D17 #x2EB4 #x0D81 #xB7BD #x5C3B #xC0BA #x6CAD
99 #xEDB8 #x8320 #x9ABF #xB3B6 #x03B6 #xE20C #x74B1 #xD29A
100 #xEAD5 #x4739 #x9DD2 #x77AF #x04DB #x2615 #x73DC #x1683
101 #xE363 #x0B12 #x9464 #x3B84 #x0D6D #x6A3E #x7A6A #x5AA8
102 #xE40E #xCF0B #x9309 #xFF9D #x0A00 #xAE27 #x7D07 #x9EB1
103 #xF00F #x9344 #x8708 #xA3D2 #x1E01 #xF268 #x6906 #xC2FE
104 #xF762 #x575D #x8065 #x67CB #x196C #x3671 #x6E6B #x06E7
105 #xFED4 #x1B76 #x89D3 #x2BE0 #x10DA #x7A5A #x67DD #x4ACC
106 #xF9B9 #xDF6F #x8EBE #xEFF9 #x17B7 #xBE43 #x60B0 #x8ED5
107 #xD6D6 #xA3E8 #xA1D1 #x937E #x38D8 #xC2C4 #x4FDF #xF252
108 #xD1BB #x67F1 #xA6BC #x5767 #x3FB5 #x06DD #x48B2 #x364B
109 #xD80D #x2BDA #xAF0A #x1B4C #x3603 #x4AF6 #x4104 #x7A60
110 #xDF60 #xEFC3 #xA867 #xDF55 #x316E #x8EEF #x4669 #xBE79
111 #xCB61 #xB38C #xBC66 #x831A #x256F #xD2A0 #x5268 #xE236
112 #xCC0C #x7795 #xBB0B #x4703 #x2202 #x16B9 #x5505 #x262F
113 #xC5BA #x3BBE #xB2BD #x0B28 #x2BB4 #x5A92 #x5CB3 #x6A04
114 #xC2D7 #xFFA7 #xB5D0 #xCF31 #x2CD9 #x9E8B #x5BDE #xAE1D
115 #x9B64 #xC2B0 #xEC63 #xF226 #x756A #xA39C #x026D #x930A
116 #x9C09 #x06A9 #xEB0E #x363F #x7207 #x6785 #x0500 #x5713
117 #x95BF #x4A82 #xE2B8 #x7A14 #x7BB1 #x2BAE #x0CB6 #x1B38
118 #x92D2 #x8E9B #xE5D5 #xBE0D #x7CDC #xEFB7 #x0BDB #xDF21
119 #x86D3 #xD2D4 #xF1D4 #xE242 #x68DD #xB3F8 #x1FDA #x836E
120 #x81BE #x16CD #xF6B9 #x265B #x6FB0 #x77E1 #x18B7 #x4777
121 #x8808 #x5AE6 #xFF0F #x6A70 #x6606 #x3BCA #x1101 #x0B5C
122 #x8F65 #x9EFF #xF862 #xAE69 #x616B #xFFD3 #x166C #xCF45
123 #xA00A #xE278 #xD70D #xD2EE #x4E04 #x8354 #x3903 #xB3C2
124 #xA767 #x2661 #xD060 #x16F7 #x4969 #x474D #x3E6E #x77DB
125 #xAED1 #x6A4A #xD9D6 #x5ADC #x40DF #x0B66 #x37D8 #x3BF0
126 #xA9BC #xAE53 #xDEBB #x9EC5 #x47B2 #xCF7F #x30B5 #xFFE9
127 #xBDBD #xF21C #xCABA #xC28A #x53B3 #x9330 #x24B4 #xA3A6
128 #xBAD0 #x3605 #xCDD7 #x0693 #x54DE #x5729 #x23D9 #x67BF
129 #xB366 #x7A2E #xC461 #x4AB8 #x5D68 #x1B02 #x2A6F #x2B94
130 #xB40B #xBE37 #xC30C #x8EA1 #x5A05 #xDF1B #x2D02 #xEF8D
131 ))
133 (define (digest-update-crc32 digest u8vect start end)
134 (let ((state (digest-state digest)))
135 (let ((hi16 (crc32-digest-hi16 state))
136 (lo16 (crc32-digest-lo16 state)))
137 (let loop ((i start)
138 (hi hi16)
139 (lo lo16))
140 (if (fx< i end)
141 (let* ((x (u8vector-ref u8vect i))
142 (j (fx* 2 (fxand (fxxor lo x) #xff)))
143 (crc-hi (vector-ref crc32-table j))
144 (crc-lo (vector-ref crc32-table (fx+ j 1))))
145 (loop (fx+ i 1)
146 (fxxor
147 crc-hi
148 (fxarithmetic-shift-right hi 8))
149 (fxxor
150 crc-lo
151 (fx+ (fxarithmetic-shift-left (fxand hi #xff) 8)
152 (fxarithmetic-shift-right lo 8)))))
153 (begin
154 (crc32-digest-hi16-set! state hi)
155 (crc32-digest-lo16-set! state lo)))))))
157 (define (end-crc32 digest result-type)
159 (define (hex16 n) ;; assumes n is a fixnum
160 (let* ((s (number->string n 16))
161 (len (string-length s)))
162 (if (fx= len 4)
163 s
164 (string-append (make-string (fx- 4 len) #\0) s))))
166 (let ((state (digest-state digest)))
167 (let ((hi16 (fxxor (crc32-digest-hi16 state) #xffff))
168 (lo16 (fxxor (crc32-digest-lo16 state) #xffff)))
169 (case result-type
170 ((hex)
171 (string-append (hex16 hi16) (hex16 lo16)))
172 ((u8vector)
173 (u8vector (fxand #xff lo16)
174 (fxarithmetic-shift-right lo16 8)
175 (fxand #xff hi16)
176 (fxarithmetic-shift-right hi16 8)))
177 (else
178 (error "unsupported digest result-type" result-type))))))
180 (define (open-digest-crc32)
181 (make-digest
182 end-crc32
183 digest-update-crc32
184 (make-crc32-digest #xffff #xffff)))
186 ;; Useful for debugging:
188 #;
189 (begin
191 (namespace ("" arithmetic-shift bitwise-and bitwise-xor))
193 (define crc32-poly #xEDB88320)
195 (define crc32-table-computed
196 (let ((v (make-vector 512)))
197 (let loop1 ((n 0))
198 (if (fx< n 256)
199 (let loop2 ((k 0) (c n))
200 (if (fx< k 8)
201 (loop2 (fx+ k 1)
202 (if (odd? c)
203 (bitwise-xor crc32-poly
204 (arithmetic-shift c -1))
205 (arithmetic-shift c -1)))
206 (begin
207 (vector-set! v (fx* n 2) (arithmetic-shift c -16))
208 (vector-set! v (fx+ 1 (fx* n 2)) (bitwise-and c #xffff))
209 (loop1 (fx+ n 1)))))))
210 v))
212 (if (not (equal? crc32-table-computed crc32-table))
213 (error "crc32-table is incorrect"))
215 #;
216 (define (digest-update-crc32 digest u8vect start end)
217 (let ((state (digest-state digest)))
218 (let ((hi16 (crc32-digest-hi16 state))
219 (lo16 (crc32-digest-lo16 state)))
220 (let loop ((i start)
221 (crc (fx+ (arithmetic-shift hi16 16)
222 lo16)))
223 (if (fx< i end)
224 (let* ((x (u8vector-ref u8vect i))
225 (crc (bitwise-xor crc x)))
226 (let loop2 ((j 8) (crc crc))
227 (if (fx> j 0)
228 (loop2 (fx- j 1)
229 (if (odd? crc)
230 (bitwise-xor crc32-poly
231 (arithmetic-shift crc -1))
232 (arithmetic-shift crc -1)))
233 (loop (fx+ i 1)
234 crc))))
235 (begin
236 (crc32-digest-hi16-set!
237 state
238 (arithmetic-shift crc -16))
239 (crc32-digest-lo16-set!
240 state
241 (bitwise-and crc #xffff))))))))
242 )
244 ;;;----------------------------------------------------------------------------
246 (define (hash-block->hex-string hb big-endian? width)
248 (define (hex x)
249 (string-ref "0123456789abcdef" (fxand x 15)))
251 (let* ((len (fxquotient width 16))
252 (n (fx* len 4))
253 (str (make-string n)))
254 (let loop ((i (fx- len 1)) (j (fx- n 4)))
255 (if (fx< i 0)
256 str
257 (let ((x (vector-ref hb (if big-endian? (fxxor i 1) i)))
258 (j1 (if big-endian? (fx+ j 0) (fx+ j 2)))
259 (j2 (if big-endian? (fx+ j 2) (fx+ j 0))))
260 (string-set!
261 str
262 (fx+ j1 0)
263 (hex (fxarithmetic-shift-right x 12)))
264 (string-set!
265 str
266 (fx+ j1 1)
267 (hex (fxarithmetic-shift-right x 8)))
268 (string-set!
269 str
270 (fx+ j2 0)
271 (hex (fxarithmetic-shift-right x 4)))
272 (string-set!
273 str
274 (fx+ j2 1)
275 (hex (fxarithmetic-shift-right x 0)))
276 (loop (fx- i 1) (fx- j 4)))))))
278 (define (hash-block->u8vector hb big-endian? width)
279 (let* ((len (fxquotient width 16))
280 (n (fx* len 2))
281 (u8vect (make-u8vector n 0)))
282 (let loop ((i (fx- len 1)) (j (fx- n 2)))
283 (if (fx< i 0)
284 u8vect
285 (let ((x (vector-ref hb (if big-endian? (fxxor i 1) i)))
286 (j1 (if big-endian? (fx+ j 0) (fx+ j 1)))
287 (j2 (if big-endian? (fx+ j 1) (fx+ j 0))))
288 (u8vector-set! u8vect j1 (fxarithmetic-shift-right x 8))
289 (u8vector-set! u8vect j2 (fxand #xff x))
290 (loop (fx- i 1) (fx- j 2)))))))
292 (define-macro (LO var)
293 (string->symbol
294 (string-append (symbol->string var) "-" (symbol->string 'L))))
296 (define-macro (HI var)
297 (string->symbol
298 (string-append (symbol->string var) "-" (symbol->string 'H))))
300 (define-macro (wlet var lo hi body)
301 `(let ((,(string->symbol
302 (string-append (symbol->string var) "-" (symbol->string 'L)))
303 ,lo)
304 (,(string->symbol
305 (string-append (symbol->string var) "-" (symbol->string 'H)))
306 ,hi))
307 ,body))
309 (define-macro (cast-u16 x)
310 `(fxand #xffff ,x))
312 (define-macro (shift-left-u16 n shift)
313 `(fxarithmetic-shift-left
314 (fxand ,n ,(fx- (expt 2 (fx- 16 shift)) 1))
315 ,shift))
317 (define-macro (wshr dst w r body)
318 (if (fx< r 16)
319 `(wlet ,dst
320 (fxior
321 (fxarithmetic-shift-right (LO ,w) ,r)
322 (shift-left-u16 (HI ,w) ,(fx- 16 r)))
323 (fxarithmetic-shift-right (HI ,w) ,r)
324 ,body)
325 `(wlet ,dst
326 (fxarithmetic-shift-right (HI ,w) ,(fx- r 16))
327 0
328 ,body)))
330 (define-macro (wrot dst w r body)
331 (if (fx< r 16)
332 `(wlet ,dst
333 (fxior
334 (shift-left-u16 (LO ,w) ,r)
335 (fxarithmetic-shift-right (HI ,w) ,(fx- 16 r)))
336 (fxior
337 (shift-left-u16 (HI ,w) ,r)
338 (fxarithmetic-shift-right (LO ,w) ,(fx- 16 r)))
339 ,body)
340 `(wlet ,dst
341 (fxior
342 (shift-left-u16 (HI ,w) ,(fx- r 16))
343 (fxarithmetic-shift-right (LO ,w) ,(fx- 32 r)))
344 (fxior
345 (shift-left-u16 (LO ,w) ,(fx- r 16))
346 (fxarithmetic-shift-right (HI ,w) ,(fx- 32 r)))
347 ,body)))
349 (define-macro (wadd dst a b body)
350 `(wlet R
351 (fx+ (LO ,a) (LO ,b))
352 (fx+ (HI ,a) (HI ,b))
353 (wlet ,dst
354 (cast-u16 (LO R))
355 (cast-u16
356 (fx+ (HI R)
357 (fxarithmetic-shift-right (LO R) 16)))
358 ,body)))
360 (define-macro (wxor dst a b body)
361 `(wlet ,dst
362 (fxxor (LO ,a) (LO ,b))
363 (fxxor (HI ,a) (HI ,b))
364 ,body))
366 (define-macro (wior dst a b body)
367 `(wlet ,dst
368 (fxior (LO ,a) (LO ,b))
369 (fxior (HI ,a) (HI ,b))
370 ,body))
372 (define-macro (wand dst a b body)
373 `(wlet ,dst
374 (fxand (LO ,a) (LO ,b))
375 (fxand (HI ,a) (HI ,b))
376 ,body))
378 (define-macro (wnot dst a body)
379 `(wlet ,dst
380 (fxnot (LO ,a))
381 (fxnot (HI ,a))
382 ,body))
384 (define-macro (wref dst v i body)
385 (if (number? i)
386 `(wlet ,dst
387 (vector-ref ,v ,(fx+ (fx* 2 i) 0))
388 (vector-ref ,v ,(fx+ (fx* 2 i) 1))
389 ,body)
390 `(wlet ,dst
391 (vector-ref ,v (fx+ (fx* 2 ,i) 0))
392 (vector-ref ,v (fx+ (fx* 2 ,i) 1))
393 ,body)))
395 (define-macro (wset v i x)
396 (if (number? i)
397 `(begin
398 (vector-set! ,v ,(fx+ (fx* 2 i) 0) (LO ,x))
399 (vector-set! ,v ,(fx+ (fx* 2 i) 1) (HI ,x)))
400 `(begin
401 (vector-set! ,v (fx+ (fx* 2 ,i) 0) (LO ,x))
402 (vector-set! ,v (fx+ (fx* 2 ,i) 1) (HI ,x)))))
404 ;;;----------------------------------------------------------------------------
406 (define-type block-digest
407 id: block-digest-f65996cb-c1aa-4ee9-86cd-1af55b5ddb74
408 hash-update
409 hash
410 block
411 block-pos
412 bit-pos
413 big-endian?
414 width)
416 (define (convert-hash-block digest result-type)
417 (let* ((bd (digest-state digest))
418 (hash (block-digest-hash bd)))
419 (case result-type
420 ((hex)
421 (hash-block->hex-string
422 hash
423 (block-digest-big-endian? bd)
424 (block-digest-width bd)))
425 ((u8vector)
426 (hash-block->u8vector
427 hash
428 (block-digest-big-endian? bd)
429 (block-digest-width bd)))
430 (else
431 (error "unsupported digest result-type" result-type)))))
433 (define (process-last-block digest)
434 (let* ((bd
435 (digest-state digest))
436 (block-pos
437 (block-digest-block-pos bd))
438 (bit-pos
439 (block-digest-bit-pos bd))
440 (buf
441 (make-u8vector 8 0)))
443 (digest-update-u8 digest #x80) ;; add byte-aligned 1 bit
445 (let ((zero-padding-bytes
446 (fxquotient
447 (fxand 511 (fx- 448 (block-digest-bit-pos bd)))
448 8)))
449 (let loop1 ((n zero-padding-bytes))
450 (if (fx< 0 n)
451 (let ((m (fxmin 8 n)))
452 (digest-update-subu8vector
453 digest
454 buf
455 0
456 m) ;; add 0 bits
457 (loop1 (fx- n m))))))
459 (u8vector-set!
460 buf
461 0
462 (fxand #xff bit-pos))
464 (u8vector-set!
465 buf
466 1
467 (fxior
468 (fxarithmetic-shift-left (fxand #x7f block-pos) 1)
469 (fxand #x01 (fxarithmetic-shift-right bit-pos 8))))
471 (let loop2 ((i 2)
472 (n (fxarithmetic-shift-right block-pos 7)))
473 (if (fx> n 0)
474 (begin
475 (u8vector-set! buf i (fxand #xff n))
476 (loop2 (fx+ i 1)
477 (fxarithmetic-shift-right n 8)))))
479 (if (block-digest-big-endian? bd)
480 (let loop3 ((i 3))
481 (if (fx>= i 0)
482 (let ((t (u8vector-ref buf i)))
483 (u8vector-set! buf i (u8vector-ref buf (fx- 7 i)))
484 (u8vector-set! buf (fx- 7 i) t)
485 (loop3 (fx- i 1))))))
487 (digest-update-subu8vector digest buf 0 8)));; add message length (in bits)
489 (define (end-block-digest digest result-type)
490 (process-last-block digest)
491 (convert-hash-block digest result-type))
493 (define (digest-update-block-digest digest u8vect start end)
494 (let* ((bd (digest-state digest))
495 (block (block-digest-block bd)))
497 (define (aligned8 i bit-pos)
499 ;; bit-pos is a multiple of 8
501 (if (fx< i end)
502 (let ((j (fxarithmetic-shift-right bit-pos 4)))
503 (if (fx= 0 (fxand bit-pos 15))
504 (begin
505 (if (block-digest-big-endian? bd)
506 (let ((j (fxxor j 1)))
507 (vector-set!
508 block
509 j
510 (fxarithmetic-shift-left
511 (u8vector-ref u8vect i)
512 8)))
513 (vector-set!
514 block
515 j
516 (u8vector-ref u8vect i)))
517 (let ((new-bit-pos (fx+ bit-pos 8)))
518 (aligned8 (fx+ i 1) new-bit-pos)))
519 (begin
520 (if (block-digest-big-endian? bd)
521 (let ((j (fxxor j 1)))
522 (vector-set!
523 block
524 j
525 (fx+ (vector-ref block j)
526 (u8vector-ref u8vect i))))
527 (vector-set!
528 block
529 j
530 (fx+ (vector-ref block j)
531 (fxarithmetic-shift-left
532 (u8vector-ref u8vect i)
533 8))))
534 (let ((new-bit-pos (fx+ bit-pos 8)))
535 (if (fx= 512 new-bit-pos)
536 (begin
537 ((block-digest-hash-update bd) digest)
538 (block-digest-block-pos-set!
539 bd
540 (fx+ (block-digest-block-pos bd) 1))
541 (aligned16 (fx+ i 1) 0))
542 (aligned16 (fx+ i 1) new-bit-pos))))))
543 (block-digest-bit-pos-set! bd bit-pos)))
545 (define (aligned16 i bit-pos)
547 ;; bit-pos is a multiple of 16
549 (if (fx< (fx+ i 1) end)
550 (let ((j (fxarithmetic-shift-right bit-pos 4)))
551 (if (block-digest-big-endian? bd)
552 (let ((j (fxxor j 1)))
553 (vector-set!
554 block
555 j
556 (fx+
557 (fxarithmetic-shift-left
558 (u8vector-ref u8vect i)
559 8)
560 (u8vector-ref u8vect (fx+ i 1)))))
561 (vector-set!
562 block
563 j
564 (fx+
565 (fxarithmetic-shift-left
566 (u8vector-ref u8vect (fx+ i 1))
567 8)
568 (u8vector-ref u8vect i))))
569 (let ((new-bit-pos (fx+ bit-pos 16)))
570 (if (fx= 512 new-bit-pos)
571 (begin
572 ((block-digest-hash-update bd) digest)
573 (block-digest-block-pos-set!
574 bd
575 (fx+ (block-digest-block-pos bd) 1))
576 (aligned16 (fx+ i 2) 0))
577 (aligned16 (fx+ i 2) new-bit-pos))))
578 (aligned8 i bit-pos)))
580 (let ((bit-pos (block-digest-bit-pos bd)))
581 (cond ((fx= 0 (fxand bit-pos 15)) ;; 16 bit boundary?
582 (aligned16 start bit-pos))
583 (else
584 ;; (fx= 0 (fxand bit-pos 7)) ;; 8 bit boundary?
585 (aligned8 start bit-pos))))))
587 ;;;----------------------------------------------------------------------------
589 ;; MD5 digest.
591 (define (hash-block-init-md5)
592 (vector #x2301 #x6745
593 #xab89 #xefcd
594 #xdcfe #x98ba
595 #x5476 #x1032))
597 (define-macro (wstp dst w f i n-hi16 n-lo16 r body)
598 `(wlet T1
599 ,(cons (car f) (map (lambda (v) `(LO ,v)) (cdr f)))
600 ,(cons (car f) (map (lambda (v) `(HI ,v)) (cdr f)))
601 (wadd T2 ,dst T1
602 (wref T3 block ,i
603 (wadd T4 T2 T3
604 (wlet T5
605 ,n-lo16
606 ,n-hi16
607 (wadd T6 T4 T5
608 (wrot T7 T6 ,r
609 (wadd ,dst ,w T7
610 ,body)))))))))
612 (define-macro (fn-F x y z)
613 `(fxior
614 (fxand ,x ,y)
615 (fxand (fxnot ,x) ,z)))
617 (define-macro (fn-G x y z)
618 `(fxior
619 (fxand ,x ,z)
620 (fxand ,y (fxnot ,z))))
622 (define-macro (fn-H x y z)
623 `(fxxor ,x (fxxor ,y ,z)))
625 (define-macro (fn-I x y z)
626 `(cast-u16
627 (fxxor
628 ,y
629 (fxior
630 ,x
631 (fxnot ,z)))))
633 (define (digest-update-md5 digest)
634 (let* ((bd (digest-state digest))
635 (hash (block-digest-hash bd))
636 (block (block-digest-block bd)))
638 (define (stage1 A-L A-H B-L B-H C-L C-H D-L D-H)
639 (wstp A B (fn-F B C D) 0 #xD76A #xA478 7
640 (wstp D A (fn-F A B C) 1 #xE8C7 #xB756 12
641 (wstp C D (fn-F D A B) 2 #x2420 #x70DB 17
642 (wstp B C (fn-F C D A) 3 #xC1BD #xCEEE 22
643 (wstp A B (fn-F B C D) 4 #xF57C #x0FAF 7
644 (wstp D A (fn-F A B C) 5 #x4787 #xC62A 12
645 (wstp C D (fn-F D A B) 6 #xA830 #x4613 17
646 (wstp B C (fn-F C D A) 7 #xFD46 #x9501 22
647 (stage2 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))
649 (define (stage2 A-L A-H B-L B-H C-L C-H D-L D-H)
650 (wstp A B (fn-F B C D) 8 #x6980 #x98D8 7
651 (wstp D A (fn-F A B C) 9 #x8B44 #xF7AF 12
652 (wstp C D (fn-F D A B) 10 #xFFFF #x5BB1 17
653 (wstp B C (fn-F C D A) 11 #x895C #xD7BE 22
654 (wstp A B (fn-F B C D) 12 #x6B90 #x1122 7
655 (wstp D A (fn-F A B C) 13 #xFD98 #x7193 12
656 (wstp C D (fn-F D A B) 14 #xA679 #x438E 17
657 (wstp B C (fn-F C D A) 15 #x49B4 #x0821 22
658 (stage3 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))
660 (define (stage3 A-L A-H B-L B-H C-L C-H D-L D-H)
661 (wstp A B (fn-G B C D) 1 #xF61E #x2562 5
662 (wstp D A (fn-G A B C) 6 #xC040 #xB340 9
663 (wstp C D (fn-G D A B) 11 #x265E #x5A51 14
664 (wstp B C (fn-G C D A) 0 #xE9B6 #xC7AA 20
665 (wstp A B (fn-G B C D) 5 #xD62F #x105D 5
666 (wstp D A (fn-G A B C) 10 #x0244 #x1453 9
667 (wstp C D (fn-G D A B) 15 #xD8A1 #xE681 14
668 (wstp B C (fn-G C D A) 4 #xE7D3 #xFBC8 20
669 (stage4 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))
671 (define (stage4 A-L A-H B-L B-H C-L C-H D-L D-H)
672 (wstp A B (fn-G B C D) 9 #x21E1 #xCDE6 5
673 (wstp D A (fn-G A B C) 14 #xC337 #x07D6 9
674 (wstp C D (fn-G D A B) 3 #xF4D5 #x0D87 14
675 (wstp B C (fn-G C D A) 8 #x455A #x14ED 20
676 (wstp A B (fn-G B C D) 13 #xA9E3 #xE905 5
677 (wstp D A (fn-G A B C) 2 #xFCEF #xA3F8 9
678 (wstp C D (fn-G D A B) 7 #x676F #x02D9 14
679 (wstp B C (fn-G C D A) 12 #x8D2A #x4C8A 20
680 (stage5 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))
682 (define (stage5 A-L A-H B-L B-H C-L C-H D-L D-H)
683 (wstp A B (fn-H B C D) 5 #xFFFA #x3942 4
684 (wstp D A (fn-H A B C) 8 #x8771 #xF681 11
685 (wstp C D (fn-H D A B) 11 #x6D9D #x6122 16
686 (wstp B C (fn-H C D A) 14 #xFDE5 #x380C 23
687 (wstp A B (fn-H B C D) 1 #xA4BE #xEA44 4
688 (wstp D A (fn-H A B C) 4 #x4BDE #xCFA9 11
689 (wstp C D (fn-H D A B) 7 #xF6BB #x4B60 16
690 (wstp B C (fn-H C D A) 10 #xBEBF #xBC70 23
691 (stage6 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))
693 (define (stage6 A-L A-H B-L B-H C-L C-H D-L D-H)
694 (wstp A B (fn-H B C D) 13 #x289B #x7EC6 4
695 (wstp D A (fn-H A B C) 0 #xEAA1 #x27FA 11
696 (wstp C D (fn-H D A B) 3 #xD4EF #x3085 16
697 (wstp B C (fn-H C D A) 6 #x0488 #x1D05 23
698 (wstp A B (fn-H B C D) 9 #xD9D4 #xD039 4
699 (wstp D A (fn-H A B C) 12 #xE6DB #x99E5 11
700 (wstp C D (fn-H D A B) 15 #x1FA2 #x7CF8 16
701 (wstp B C (fn-H C D A) 2 #xC4AC #x5665 23
702 (stage7 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))
704 (define (stage7 A-L A-H B-L B-H C-L C-H D-L D-H)
705 (wstp A B (fn-I B C D) 0 #xF429 #x2244 6
706 (wstp D A (fn-I A B C) 7 #x432A #xFF97 10
707 (wstp C D (fn-I D A B) 14 #xAB94 #x23A7 15
708 (wstp B C (fn-I C D A) 5 #xFC93 #xA039 21
709 (wstp A B (fn-I B C D) 12 #x655B #x59C3 6
710 (wstp D A (fn-I A B C) 3 #x8F0C #xCC92 10
711 (wstp C D (fn-I D A B) 10 #xFFEF #xF47D 15
712 (wstp B C (fn-I C D A) 1 #x8584 #x5DD1 21
713 (stage8 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))
715 (define (stage8 A-L A-H B-L B-H C-L C-H D-L D-H)
716 (wstp A B (fn-I B C D) 8 #x6FA8 #x7E4F 6
717 (wstp D A (fn-I A B C) 15 #xFE2C #xE6E0 10
718 (wstp C D (fn-I D A B) 6 #xA301 #x4314 15
719 (wstp B C (fn-I C D A) 13 #x4E08 #x11A1 21
720 (wstp A B (fn-I B C D) 4 #xF753 #x7E82 6
721 (wstp D A (fn-I A B C) 11 #xBD3A #xF235 10
722 (wstp C D (fn-I D A B) 2 #x2AD7 #xD2BB 15
723 (wstp B C (fn-I C D A) 9 #xEB86 #xD391 21
724 (stage9 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))
726 (define (stage9 A-L A-H B-L B-H C-L C-H D-L D-H)
727 (wref AA hash 0 (wadd A AA A (wset hash 0 A)))
728 (wref BB hash 1 (wadd B BB B (wset hash 1 B)))
729 (wref CC hash 2 (wadd C CC C (wset hash 2 C)))
730 (wref DD hash 3 (wadd D DD D (wset hash 3 D))))
732 (wref A hash 0
733 (wref B hash 1
734 (wref C hash 2
735 (wref D hash 3
736 (stage1 A-L A-H B-L B-H C-L C-H D-L D-H)))))))
738 (define (open-digest-md5)
739 (make-digest
740 end-block-digest
741 digest-update-block-digest
742 (make-block-digest
743 digest-update-md5
744 (hash-block-init-md5)
745 (make-vector 32 0)
746 0
747 0
748 #f
749 128)))
751 ;;;----------------------------------------------------------------------------
753 ;; SHA-1 digest.
755 (define (hash-block-init-sha-1)
756 (vector #x2301 #x6745
757 #xab89 #xefcd
758 #xdcfe #x98ba
759 #x5476 #x1032
760 #xe1f0 #xc3d2))
762 (define (digest-update-sha-1 digest)
763 (let* ((bd (digest-state digest))
764 (hash (block-digest-hash bd))
765 (block (block-digest-block bd)))
766 (wref OLDA hash 0
767 (wref OLDB hash 1
768 (wref OLDC hash 2
769 (wref OLDD hash 3
770 (wref OLDE hash 4
771 (let loop ((j 0)
772 (A-L OLDA-L) (A-H OLDA-H)
773 (B-L OLDB-L) (B-H OLDB-H)
774 (C-L OLDC-L) (C-H OLDC-H)
775 (D-L OLDD-L) (D-H OLDD-H)
776 (E-L OLDE-L) (E-H OLDE-H))
778 (define (stage1)
779 (if (fx< j 16)
781 (wref T1 block j
782 (stage2 T1-L T1-H))
784 (wref T1 block (fx- j 3)
785 (wref T2 block (fx- j 8)
786 (wxor T3 T1 T2
787 (wref T4 block (fx- j 14)
788 (wxor T5 T3 T4
789 (wref T6 block (fx- j 16)
790 (wxor T7 T5 T6
791 (wrot X T7 1
792 (begin
793 (wset block j X)
794 (stage2 X-L X-H))))))))))))
796 (define (stage2 X-L X-H)
797 (cond ((fx< j 20)
798 (wand T1 B C
799 (wnot T2 B
800 (wand T3 D T2
801 (wior T4 T1 T3
802 (wlet T5 #x7999 #x5a82
803 (wadd T6 T4 T5
804 (stage3 X-L X-H T6-L T6-H))))))))
805 ((fx< j 40)
806 (wxor T1 B C
807 (wxor T2 D T1
808 (wlet T3 #xeba1 #x6ed9
809 (wadd T4 T2 T3
810 (stage3 X-L X-H T4-L T4-H))))))
811 ((fx< j 60)
812 (wand T1 B C
813 (wand T2 B D
814 (wior T3 T1 T2
815 (wand T4 C D
816 (wior T5 T3 T4
817 (wlet T6 #xbcdc #x8f1b
818 (wadd T7 T5 T6
819 (stage3 X-L X-H T7-L T7-H)))))))))
820 (else
821 (wxor T1 B C
822 (wxor T2 D T1
823 (wlet T3 #xc1d6 #xca62
824 (wadd T4 T2 T3
825 (stage3 X-L X-H T4-L T4-H))))))))
827 (define (stage3 X-L X-H Y-L Y-H)
828 (wrot T1 A 5
829 (wadd T2 E T1
830 (wadd T3 X T2
831 (wadd T4 Y T3
832 (wrot T5 B 30
833 (loop (fx+ j 1)
834 T4-L T4-H
835 A-L A-H
836 T5-L T5-H
837 C-L C-H
838 D-L D-H)))))))
840 (if (fx< j 80)
842 (stage1)
844 (begin
845 (wadd NEWA A OLDA (wset hash 0 NEWA))
846 (wadd NEWB B OLDB (wset hash 1 NEWB))
847 (wadd NEWC C OLDC (wset hash 2 NEWC))
848 (wadd NEWD D OLDD (wset hash 3 NEWD))
849 (wadd NEWE E OLDE (wset hash 4 NEWE))))))))))))
851 (define (open-digest-sha-1)
852 (make-digest
853 end-block-digest
854 digest-update-block-digest
855 (make-block-digest
856 digest-update-sha-1
857 (hash-block-init-sha-1)
858 (make-vector 160 0)
859 0
860 0
861 #t
862 160)))
864 ;;;----------------------------------------------------------------------------
866 ;; SHA-224 and SHA-256 digests.
868 (define (hash-block-init-sha-224)
869 (vector #x9ed8 #xc105
870 #xd507 #x367c
871 #xdd17 #x3070
872 #x5939 #xf70e
873 #x0b31 #xffc0
874 #x1511 #x6858
875 #x8fa7 #x64f9
876 #x4fa4 #xbefa))
878 (define (hash-block-init-sha-256)
879 (vector #xe667 #x6a09
880 #xae85 #xbb67
881 #xf372 #x3c6e
882 #xf53a #xa54f
883 #x527f #x510e
884 #x688c #x9b05
885 #xd9ab #x1f83
886 #xcd19 #x5be0))
888 (define-macro (fn-W dst i body)
889 `(wref ,dst block ,i ,body))
891 (define-macro (fn-R dst i body)
892 `(wref T1 block ,(fx- i 15) ;; compute S0
893 (wrot T2 T1 25
894 (wrot T3 T1 14
895 (wxor T4 T2 T3
896 (wshr T5 T1 3
897 (wxor S0 T4 T5
898 (wref T6 block ,(fx- i 2) ;; compute S1
899 (wrot T7 T6 15
900 (wrot T8 T6 13
901 (wxor T9 T7 T8
902 (wshr T10 T6 10
903 (wxor S1 T9 T10
904 (wadd T11 S0 S1 ;; compute sum
905 (wref T12 block ,(fx- i 7)
906 (wadd T13 T11 T12
907 (wref T14 block ,(fx- i 16)
908 (wadd ,dst T13 T14
909 (begin (wset block ,i ,dst)
910 ,body)))))))))))))))))))
912 (define-macro (fn-P a b c d e f g h x i k-hi16 k-lo16 body)
913 `(wrot T1 ,a 30 ;; compute S2
914 (wrot T2 ,a 19
915 (wxor T3 T1 T2
916 (wrot T4 ,a 10
917 (wxor S2 T3 T4
918 (wrot T5 ,e 26 ;; compute S3
919 (wrot T6 ,e 21
920 (wxor T7 T5 T6
921 (wrot T8 ,e 7
922 (wxor S3 T7 T8
923 (wior T9 ,a ,b ;; compute F0
924 (wand T10 ,c T9
925 (wand T11 ,a ,b
926 (wior F0 T10 T11
927 (wxor T12 ,f ,g ;; compute F1
928 (wand T13 ,e T12
929 (wxor F1 ,g T13
930 (,x T14 ,i ;; compute (fn-W i) or (fn-R i)
931 (wadd T15 T14 S3 ;; compute sum
932 (wadd T16 F1 T15
933 (wlet T17 ,k-lo16 ,k-hi16
934 (wadd T18 T16 T17
935 (wadd T19 ,h T18
936 (wadd T20 S2 F0
937 (wadd ,d T19 ,d
938 (wadd ,h T19 T20
939 ,body)))))))))))))))))))))))))))
941 (define (digest-update-sha-256 digest)
942 (let* ((bd (digest-state digest))
943 (hash (block-digest-hash bd))
944 (block (block-digest-block bd)))
946 (define (stage1 A-L A-H B-L B-H C-L C-H D-L D-H
947 E-L E-H F-L F-H G-L G-H H-L H-H)
948 (fn-P A B C D E F G H fn-W 0 #x428A #x2F98
949 (fn-P H A B C D E F G fn-W 1 #x7137 #x4491
950 (fn-P G H A B C D E F fn-W 2 #xB5C0 #xFBCF
951 (fn-P F G H A B C D E fn-W 3 #xE9B5 #xDBA5
952 (fn-P E F G H A B C D fn-W 4 #x3956 #xC25B
953 (fn-P D E F G H A B C fn-W 5 #x59F1 #x11F1
954 (fn-P C D E F G H A B fn-W 6 #x923F #x82A4
955 (fn-P B C D E F G H A fn-W 7 #xAB1C #x5ED5
956 (stage2 A-L A-H B-L B-H C-L C-H D-L D-H
957 E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
959 (define (stage2 A-L A-H B-L B-H C-L C-H D-L D-H
960 E-L E-H F-L F-H G-L G-H H-L H-H)
961 (fn-P A B C D E F G H fn-W 8 #xD807 #xAA98
962 (fn-P H A B C D E F G fn-W 9 #x1283 #x5B01
963 (fn-P G H A B C D E F fn-W 10 #x2431 #x85BE
964 (fn-P F G H A B C D E fn-W 11 #x550C #x7DC3
965 (fn-P E F G H A B C D fn-W 12 #x72BE #x5D74
966 (fn-P D E F G H A B C fn-W 13 #x80DE #xB1FE
967 (fn-P C D E F G H A B fn-W 14 #x9BDC #x06A7
968 (fn-P B C D E F G H A fn-W 15 #xC19B #xF174
969 (stage3 A-L A-H B-L B-H C-L C-H D-L D-H
970 E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
972 (define (stage3 A-L A-H B-L B-H C-L C-H D-L D-H
973 E-L E-H F-L F-H G-L G-H H-L H-H)
974 (fn-P A B C D E F G H fn-R 16 #xE49B #x69C1
975 (fn-P H A B C D E F G fn-R 17 #xEFBE #x4786
976 (fn-P G H A B C D E F fn-R 18 #x0FC1 #x9DC6
977 (fn-P F G H A B C D E fn-R 19 #x240C #xA1CC
978 (fn-P E F G H A B C D fn-R 20 #x2DE9 #x2C6F
979 (fn-P D E F G H A B C fn-R 21 #x4A74 #x84AA
980 (fn-P C D E F G H A B fn-R 22 #x5CB0 #xA9DC
981 (fn-P B C D E F G H A fn-R 23 #x76F9 #x88DA
982 (stage4 A-L A-H B-L B-H C-L C-H D-L D-H
983 E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
985 (define (stage4 A-L A-H B-L B-H C-L C-H D-L D-H
986 E-L E-H F-L F-H G-L G-H H-L H-H)
987 (fn-P A B C D E F G H fn-R 24 #x983E #x5152
988 (fn-P H A B C D E F G fn-R 25 #xA831 #xC66D
989 (fn-P G H A B C D E F fn-R 26 #xB003 #x27C8
990 (fn-P F G H A B C D E fn-R 27 #xBF59 #x7FC7
991 (fn-P E F G H A B C D fn-R 28 #xC6E0 #x0BF3
992 (fn-P D E F G H A B C fn-R 29 #xD5A7 #x9147
993 (fn-P C D E F G H A B fn-R 30 #x06CA #x6351
994 (fn-P B C D E F G H A fn-R 31 #x1429 #x2967
995 (stage5 A-L A-H B-L B-H C-L C-H D-L D-H
996 E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
998 (define (stage5 A-L A-H B-L B-H C-L C-H D-L D-H
999 E-L E-H F-L F-H G-L G-H H-L H-H)
1000 (fn-P A B C D E F G H fn-R 32 #x27B7 #x0A85
1001 (fn-P H A B C D E F G fn-R 33 #x2E1B #x2138
1002 (fn-P G H A B C D E F fn-R 34 #x4D2C #x6DFC
1003 (fn-P F G H A B C D E fn-R 35 #x5338 #x0D13
1004 (fn-P E F G H A B C D fn-R 36 #x650A #x7354
1005 (fn-P D E F G H A B C fn-R 37 #x766A #x0ABB
1006 (fn-P C D E F G H A B fn-R 38 #x81C2 #xC92E
1007 (fn-P B C D E F G H A fn-R 39 #x9272 #x2C85
1008 (stage6 A-L A-H B-L B-H C-L C-H D-L D-H
1009 E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
1011 (define (stage6 A-L A-H B-L B-H C-L C-H D-L D-H
1012 E-L E-H F-L F-H G-L G-H H-L H-H)
1013 (fn-P A B C D E F G H fn-R 40 #xA2BF #xE8A1
1014 (fn-P H A B C D E F G fn-R 41 #xA81A #x664B
1015 (fn-P G H A B C D E F fn-R 42 #xC24B #x8B70
1016 (fn-P F G H A B C D E fn-R 43 #xC76C #x51A3
1017 (fn-P E F G H A B C D fn-R 44 #xD192 #xE819
1018 (fn-P D E F G H A B C fn-R 45 #xD699 #x0624
1019 (fn-P C D E F G H A B fn-R 46 #xF40E #x3585
1020 (fn-P B C D E F G H A fn-R 47 #x106A #xA070
1021 (stage7 A-L A-H B-L B-H C-L C-H D-L D-H
1022 E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
1024 (define (stage7 A-L A-H B-L B-H C-L C-H D-L D-H
1025 E-L E-H F-L F-H G-L G-H H-L H-H)
1026 (fn-P A B C D E F G H fn-R 48 #x19A4 #xC116
1027 (fn-P H A B C D E F G fn-R 49 #x1E37 #x6C08
1028 (fn-P G H A B C D E F fn-R 50 #x2748 #x774C
1029 (fn-P F G H A B C D E fn-R 51 #x34B0 #xBCB5
1030 (fn-P E F G H A B C D fn-R 52 #x391C #x0CB3
1031 (fn-P D E F G H A B C fn-R 53 #x4ED8 #xAA4A
1032 (fn-P C D E F G H A B fn-R 54 #x5B9C #xCA4F
1033 (fn-P B C D E F G H A fn-R 55 #x682E #x6FF3
1034 (stage8 A-L A-H B-L B-H C-L C-H D-L D-H
1035 E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
1037 (define (stage8 A-L A-H B-L B-H C-L C-H D-L D-H
1038 E-L E-H F-L F-H G-L G-H H-L H-H)
1039 (fn-P A B C D E F G H fn-R 56 #x748F #x82EE
1040 (fn-P H A B C D E F G fn-R 57 #x78A5 #x636F
1041 (fn-P G H A B C D E F fn-R 58 #x84C8 #x7814
1042 (fn-P F G H A B C D E fn-R 59 #x8CC7 #x0208
1043 (fn-P E F G H A B C D fn-R 60 #x90BE #xFFFA
1044 (fn-P D E F G H A B C fn-R 61 #xA450 #x6CEB
1045 (fn-P C D E F G H A B fn-R 62 #xBEF9 #xA3F7
1046 (fn-P B C D E F G H A fn-R 63 #xC671 #x78F2
1047 (stage9 A-L A-H B-L B-H C-L C-H D-L D-H
1048 E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
1050 (define (stage9 A-L A-H B-L B-H C-L C-H D-L D-H
1051 E-L E-H F-L F-H G-L G-H H-L H-H)
1052 (wref OLDA hash 0 (wadd NEWA A OLDA (wset hash 0 NEWA)))
1053 (wref OLDB hash 1 (wadd NEWB B OLDB (wset hash 1 NEWB)))
1054 (wref OLDC hash 2 (wadd NEWC C OLDC (wset hash 2 NEWC)))
1055 (wref OLDD hash 3 (wadd NEWD D OLDD (wset hash 3 NEWD)))
1056 (wref OLDE hash 4 (wadd NEWE E OLDE (wset hash 4 NEWE)))
1057 (wref OLDF hash 5 (wadd NEWF F OLDF (wset hash 5 NEWF)))
1058 (wref OLDG hash 6 (wadd NEWG G OLDG (wset hash 6 NEWG)))
1059 (wref OLDH hash 7 (wadd NEWH H OLDH (wset hash 7 NEWH))))
1061 (wref A hash 0
1062 (wref B hash 1
1063 (wref C hash 2
1064 (wref D hash 3
1065 (wref E hash 4
1066 (wref F hash 5
1067 (wref G hash 6
1068 (wref H hash 7
1069 (stage1 A-L A-H B-L B-H C-L C-H D-L D-H
1070 E-L E-H F-L F-H G-L G-H H-L H-H)))))))))))
1072 (define (open-digest-sha-224)
1073 (make-digest
1074 end-block-digest
1075 digest-update-block-digest
1076 (make-block-digest
1077 digest-update-sha-256
1078 (hash-block-init-sha-224)
1079 (make-vector 160 0)
1080 0
1081 0
1082 #t
1083 224)))
1085 (define (open-digest-sha-256)
1086 (make-digest
1087 end-block-digest
1088 digest-update-block-digest
1089 (make-block-digest
1090 digest-update-sha-256
1091 (hash-block-init-sha-256)
1092 (make-vector 160 0)
1093 0
1094 0
1095 #t
1096 256)))
1098 ;;;----------------------------------------------------------------------------
1100 (define (open-digest algorithm)
1101 (case algorithm
1102 ((crc32 CRC32)
1103 (open-digest-crc32))
1104 ((md5 MD5)
1105 (open-digest-md5))
1106 ((sha-1 SHA-1)
1107 (open-digest-sha-1))
1108 ((sha-224 SHA-224)
1109 (open-digest-sha-224))
1110 ((sha-256 SHA-256)
1111 (open-digest-sha-256))
1112 ;; ((sha-384 SHA-384)
1113 ;; (open-digest-sha-384))
1114 ;; ((sha-512 SHA-512)
1115 ;; (open-digest-sha-512))
1116 (else
1117 (error "unknown hashing algorithm" algorithm))))
1119 (define-macro (digest-default-result-type) ''hex)
1121 (define (close-digest
1122 digest
1123 #!optional
1124 (result-type (digest-default-result-type)))
1125 ((digest-end digest) digest result-type))
1127 (define (digest-update-subu8vector digest u8vect start end)
1128 ((digest-update digest) digest u8vect start end))
1130 (define zero-u8vector (make-u8vector 4 0))
1132 (define (get-zero-u8vector) zero-u8vector)
1134 (define (digest-update-u8 digest n) ;; assumes n is a fixnum
1135 (digest-update-subu8vector
1136 digest
1137 (if (eqv? n 0)
1138 (get-zero-u8vector)
1139 (make-u8vector 1 (fxand n #xff)))
1140 0
1141 1))
1143 (define (digest-update-u16-le digest n) ;; assumes n is a fixnum
1144 (digest-update-subu8vector
1145 digest
1146 (if (eqv? n 0)
1147 (get-zero-u8vector)
1148 (let ((u8vect (make-u8vector 2)))
1149 (u8vector-set!
1150 u8vect
1151 0
1152 (fxand n #xff))
1153 (u8vector-set!
1154 u8vect
1155 1
1156 (fxand (fxarithmetic-shift-right n 8) #xff))
1157 u8vect))
1158 0
1159 2))
1161 (define (digest-update-u16-be digest n) ;; assumes n is a fixnum
1162 (digest-update-subu8vector
1163 digest
1164 (if (eqv? n 0)
1165 (get-zero-u8vector)
1166 (let ((u8vect (make-u8vector 2)))
1167 (u8vector-set!
1168 u8vect
1169 1
1170 (fxand n #xff))
1171 (u8vector-set!
1172 u8vect
1173 0
1174 (fxand (fxarithmetic-shift-right n 8) #xff))
1175 u8vect))
1176 0
1177 2))
1179 (define (digest-update-u32-le digest n) ;; assumes n is a fixnum
1180 (digest-update-subu8vector
1181 digest
1182 (if (eqv? n 0)
1183 (get-zero-u8vector)
1184 (let ((u8vect (make-u8vector 4)))
1185 (u8vector-set!
1186 u8vect
1187 0
1188 (fxand n #xff))
1189 (u8vector-set!
1190 u8vect
1191 1
1192 (fxand (fxarithmetic-shift-right n 8) #xff))
1193 (u8vector-set!
1194 u8vect
1195 2
1196 (fxand (fxarithmetic-shift-right n 16) #xff))
1197 (u8vector-set!
1198 u8vect
1199 3
1200 (fxand (fxarithmetic-shift-right n 24) #xff))
1201 u8vect))
1202 0
1203 4))
1205 (define (digest-update-u32-be digest n) ;; assumes n is a fixnum
1206 (digest-update-subu8vector
1207 digest
1208 (if (eqv? n 0)
1209 (get-zero-u8vector)
1210 (let ((u8vect (make-u8vector 4)))
1211 (u8vector-set!
1212 u8vect
1213 3
1214 (fxand n #xff))
1215 (u8vector-set!
1216 u8vect
1217 2
1218 (fxand (fxarithmetic-shift-right n 8) #xff))
1219 (u8vector-set!
1220 u8vect
1221 1
1222 (fxand (fxarithmetic-shift-right n 16) #xff))
1223 (u8vector-set!
1224 u8vect
1225 0
1226 (fxand (fxarithmetic-shift-right n 24) #xff))
1227 u8vect))
1228 0
1229 4))
1231 (define (digest-string
1232 str
1233 algorithm
1234 #!optional
1235 (result-type (digest-default-result-type)))
1236 (digest-substring
1237 str
1238 0
1239 (string-length str)
1240 algorithm
1241 result-type))
1243 (define (digest-substring
1244 str
1245 start
1246 end
1247 algorithm
1248 #!optional
1249 (result-type (digest-default-result-type)))
1250 (let* ((len (fx- end start))
1251 (u8vect (make-u8vector len)))
1252 (let loop ((i 0))
1253 (if (fx< i len)
1254 (begin
1255 (u8vector-set! u8vect i (char->integer (string-ref str i)))
1256 (loop (fx+ i 1)))
1257 (digest-subu8vector u8vect 0 len algorithm result-type)))))
1259 (define (digest-u8vector
1260 u8vect
1261 algorithm
1262 #!optional
1263 (result-type (digest-default-result-type)))
1264 (digest-subu8vector
1265 u8vect
1266 0
1267 (u8vector-length u8vect)
1268 algorithm
1269 result-type))
1271 (define (digest-subu8vector
1272 u8vect
1273 start
1274 end
1275 algorithm
1276 #!optional
1277 (result-type (digest-default-result-type)))
1278 (let ((digest (open-digest algorithm)))
1279 (digest-update-subu8vector digest u8vect start end)
1280 (close-digest digest result-type)))
1282 (define (digest-file
1283 filename
1284 algorithm
1285 #!optional
1286 (result-type (digest-default-result-type)))
1287 (let ((digest (open-digest algorithm)))
1288 (let* ((in (open-input-file filename))
1289 (bufsize 1024)
1290 (buf (make-u8vector bufsize)))
1291 (let loop ()
1292 (let ((n (read-subu8vector buf 0 bufsize in)))
1293 (if (fx= n 0)
1294 (begin
1295 (close-input-port in)
1296 (close-digest digest result-type))
1297 (begin
1298 (digest-update-subu8vector digest buf 0 n)
1299 (loop))))))))
1301 ;;;----------------------------------------------------------------------------
1303 ;; Self tests.
1305 #;
1306 (begin
1308 (define crc32-test-vectors
1309 '(
1310 ("" 0 ""
1311 "00000000")
1312 ("" 0 "a"
1313 "e8b7be43")
1314 ("" 0 "abc"
1315 "352441c2")
1316 ("" 0 "abcdefghijklmnopqrstuvwxyz"
1317 "4c2750bd")
1318 ("" 0 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
1319 "1fc2e6d2")
1320 ("" 0 "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
1321 "7ca94a72")
1322 ))
1324 (define md5-test-vectors
1325 '(
1326 ;; from RFC 1321:
1327 ("" 0 ""
1328 "d41d8cd98f00b204e9800998ecf8427e")
1329 ("" 0 "a"
1330 "0cc175b9c0f1b6a831c399e269772661")
1331 ("" 0 "abc"
1332 "900150983cd24fb0d6963f7d28e17f72")
1333 ("" 0 "message digest"
1334 "f96b697d7cb7938d525a2f31aaf161d0")
1335 ("" 0 "abcdefghijklmnopqrstuvwxyz"
1336 "c3fcd3d76192e4007dfb496cca67e13b")
1337 ("" 0 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
1338 "d174ab98d277d9f5a5611c2c9f419d9f")
1339 ("" 0 "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
1340 "57edf4a22be3c955ac49da2e2107b67a")
1341 ))
1343 (define sha-1-test-vectors
1344 '(
1345 ("" 0 ""
1346 "da39a3ee5e6b4b0d3255bfef95601890afd80709")
1347 ;; from RFC 3174:
1348 ("" 0 "abc"
1349 "a9993e364706816aba3e25717850c26c9cd0d89d")
1350 ("" 0 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
1351 "84983e441c3bd26ebaae4aa1f95129e5e54670f1")
1352 ;; ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" 10000 ""
1353 ;; "34aa973cd4c4daa4f61eeb2bdbad27316534016f")
1354 ("0123456701234567012345670123456701234567012345670123456701234567" 10 ""
1355 "dea356a2cddd90c7a7ecedc5ebb563934f460452")
1356 ))
1358 (define sha-224-test-vectors
1359 '(
1360 ;; from RFC 3874:
1361 ("" 0 "abc"
1362 "23097d223405d8228642a477bda255b32aadbce4bda0b3f7e36c9da7")
1363 ("" 0 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
1364 "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525")
1365 ;; ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" 10000 ""
1366 ;; "20794655980c91d8bbb4c1ea97618a4bf03f42581948b2ee4ee7ad67")
1367 ))
1369 (define sha-256-test-vectors
1370 '(
1371 ("" 0 ""
1372 "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855")
1373 ;; from FIPS-180-2:
1374 ("" 0 "abc"
1375 "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad")
1376 ("" 0 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
1377 "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1")
1378 ;; ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" 10000 ""
1379 ;; "cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0")
1380 ))
1382 (define (test-digest)
1384 (define (t algorithm vectors)
1386 (namespace ("" pp list->u8vector))
1388 (for-each
1389 (lambda (v)
1390 (let ((str1 (car v))
1391 (repeat (cadr v))
1392 (str2 (caddr v))
1393 (expect (cadddr v)))
1394 (let ((md
1395 (if (fx= repeat 0)
1396 (digest-string str2 algorithm 'hex)
1397 (let ((u8vect1
1398 (list->u8vector
1399 (map char->integer (string->list str1))))
1400 (u8vect2
1401 (list->u8vector
1402 (map char->integer (string->list str2))))
1403 (digest
1404 (open-digest algorithm)))
1405 (let loop ((i 0))
1406 (if (fx< i repeat)
1407 (begin
1408 (digest-update-subu8vector
1409 digest
1410 u8vect1
1411 0
1412 (u8vector-length u8vect1))
1413 (loop (fx+ i 1)))
1414 (begin
1415 (digest-update-subu8vector
1416 digest
1417 u8vect2
1418 0
1419 (u8vector-length u8vect2))
1420 (close-digest digest 'hex))))))))
1421 (if (not (string-ci=? md expect))
1422 (pp (list '***error*** md expect))))))
1423 vectors))
1425 (t 'crc32 crc32-test-vectors)
1426 (t 'md5 md5-test-vectors)
1427 (t 'sha-1 sha-1-test-vectors)
1428 (t 'sha-224 sha-224-test-vectors)
1429 (t 'sha-256 sha-256-test-vectors)
1430 )
1432 (test-digest))
1434 ;;;============================================================================