LOGBITP and LOGTEST optimizations from x86.
[sbcl.git] / contrib / sb-md5 / md5.lisp
1 ;;;; This file implements The MD5 Message-Digest Algorithm, as defined in
2 ;;;; RFC 1321 by R. Rivest, published April 1992.
3 ;;;;
4 ;;;; It was written by Pierre R. Mai, with copious input from the
5 ;;;; cmucl-help mailing-list hosted at cons.org, in November 2001 and
6 ;;;; has been placed into the public domain.
7 ;;;;
8 ;;;; $Id$
9 ;;;;
10 ;;;; While the implementation should work on all conforming Common
11 ;;;; Lisp implementations, it has only been optimized for CMU CL,
12 ;;;; where it achieved comparable performance to the standard md5sum
13 ;;;; utility (within a factor of 1.5 or less on iA32 and UltraSparc
14 ;;;; hardware).
15 ;;;;
16 ;;;; Since the implementation makes heavy use of arithmetic on
17 ;;;; (unsigned-byte 32) numbers, acceptable performance is likely only
18 ;;;; on CL implementations that support unboxed arithmetic on such
19 ;;;; numbers in some form.  For other CL implementations a 16bit
20 ;;;; implementation of MD5 is probably more suitable.
21 ;;;;
22 ;;;; The code implements correct operation for files of unbounded size
23 ;;;; as is, at the cost of having to do a single generic integer
24 ;;;; addition for each call to update-md5-state.  If you call
25 ;;;; update-md5-state frequently with little data, this can pose a
26 ;;;; performance problem.  If you can live with a size restriction of
27 ;;;; 512 MB, then you can enable fast fixnum arithmetic by putting
28 ;;;; :md5-small-length onto *features* prior to compiling this file.
29 ;;;;
30 ;;;; This software is "as is", and has no warranty of any kind.  The
31 ;;;; authors assume no responsibility for the consequences of any use
32 ;;;; of this software.
33
34 (defpackage :SB-MD5 (:use :CL)
35   (:export
36    ;; Low-Level types and functions
37    #:md5-regs #:initial-md5-regs #:md5regs-digest
38    #:update-md5-block #:fill-block #:fill-block-ub8 #:fill-block-char
39    ;; Mid-Level types and functions
40    #:md5-state #:md5-state-p #:make-md5-state
41    #:update-md5-state #:finalize-md5-state
42    ;; High-Level functions on sequences, streams and files
43    #:md5sum-sequence #:md5sum-string #:md5sum-stream #:md5sum-file))
44
45 (in-package :SB-MD5)
46
47 #+cmu
48 (eval-when (:compile-toplevel)
49   (defparameter *old-expansion-limit* ext:*inline-expansion-limit*)
50   (setq ext:*inline-expansion-limit* (max ext:*inline-expansion-limit* 1000)))
51
52 #+cmu
53 (eval-when (:compile-toplevel :execute)
54   (defparameter *old-features* *features*)
55   (pushnew (c:backend-byte-order c:*target-backend*) *features*))
56
57 #+sbcl
58 (eval-when (:compile-toplevel)
59   (defparameter *old-features* *features*)
60   (pushnew sb-c:*backend-byte-order* *features*))
61
62 ;;; Section 2:  Basic Datatypes
63
64 (deftype ub32 ()
65   "Corresponds to the 32bit quantity word of the MD5 Spec"
66   `(unsigned-byte 32))
67
68 (defmacro assemble-ub32 (a b c d)
69   "Assemble an ub32 value from the given (unsigned-byte 8) values,
70 where a is the intended low-order byte and d the high-order byte."
71   `(the ub32 (logior (ash ,d 24) (ash ,c 16) (ash ,b 8) ,a)))
72
73 ;;; Section 3.4:  Auxilliary functions
74
75 (declaim (inline f g h i)
76          (ftype (function (ub32 ub32 ub32) ub32) f g h i))
77
78 (defun f (x y z)
79   (declare (type ub32 x y z)
80            (optimize (speed 3) (safety 0) (space 0) (debug 0)))
81   #+cmu
82   (kernel:32bit-logical-or (kernel:32bit-logical-and x y)
83                            (kernel:32bit-logical-andc1 x z))
84   #-cmu
85   (logior (logand x y) (logandc1 x z)))
86
87 (defun g (x y z)
88   (declare (type ub32 x y z)
89            (optimize (speed 3) (safety 0) (space 0) (debug 0)))
90   #+cmu
91   (kernel:32bit-logical-or (kernel:32bit-logical-and x z)
92                            (kernel:32bit-logical-andc2 y z))
93   #-cmu
94   (logior (logand x z) (logandc2 y z)))
95
96 (defun h (x y z)
97   (declare (type ub32 x y z)
98            (optimize (speed 3) (safety 0) (space 0) (debug 0)))
99   #+cmu
100   (kernel:32bit-logical-xor x (kernel:32bit-logical-xor y z))
101   #-cmu
102   (logxor x y z))
103
104 (defun i (x y z)
105   (declare (type ub32 x y z)
106            (optimize (speed 3) (safety 0) (space 0) (debug 0)))
107   #+cmu
108   (kernel:32bit-logical-xor y (kernel:32bit-logical-orc2 x z))
109   #-cmu
110   (ldb (byte 32 0) (logxor y (logorc2 x z))))
111
112 (declaim (inline mod32+)
113          (ftype (function (ub32 ub32) ub32) mod32+))
114 (defun mod32+ (a b)
115   (declare (type ub32 a b) (optimize (speed 3) (safety 0) (space 0) (debug 0)))
116   (ldb (byte 32 0) (+ a b)))
117
118 #+cmu
119 (define-compiler-macro mod32+ (a b)
120   `(ext:truly-the ub32 (+ ,a ,b)))
121
122 ;;; Dunno why we need this, but without it MOD32+ wasn't being
123 ;;; inlined.  Oh well.  -- CSR, 2003-09-14
124 #+sbcl
125 (define-compiler-macro mod32+ (a b)
126   `(ldb (byte 32 0) (+ ,a ,b)))
127
128 (declaim (inline rol32)
129          (ftype (function (ub32 (unsigned-byte 5)) ub32) rol32))
130 (defun rol32 (a s)
131   (declare (type ub32 a) (type (unsigned-byte 5) s)
132            (optimize (speed 3) (safety 0) (space 0) (debug 0)))
133   #+cmu
134   (kernel:32bit-logical-or #+little-endian (kernel:shift-towards-end a s)
135                            #+big-endian (kernel:shift-towards-start a s)
136                            (ash a (- s 32)))
137   #+sbcl
138   (sb-rotate-byte:rotate-byte s (byte 32 0) a)
139   #-(or cmu sbcl)
140   (logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32))))
141
142 ;;; Section 3.4:  Table T
143
144 (eval-when (:compile-toplevel :load-toplevel :execute)
145   (defparameter *t* (make-array 64 :element-type 'ub32
146                                 :initial-contents
147                                 (loop for i from 1 to 64
148                                       collect
149                                       (truncate
150                                        (* 4294967296
151                                           (abs (sin (float i 0.0d0)))))))))
152
153 ;;; Section 3.4:  Helper Macro for single round definitions
154
155 (defmacro with-md5-round ((op block) &rest clauses)
156   (loop for (a b c d k s i) in clauses
157         collect
158         `(setq ,a (mod32+ ,b (rol32 (mod32+ (mod32+ ,a (,op ,b ,c ,d))
159                                             (mod32+ (aref ,block ,k)
160                                                     ,(aref *t* (1- i))))
161                                     ,s)))
162         into result
163         finally
164         (return `(progn ,@result))))
165
166 ;;; Section 3.3:  (Initial) MD5 Working Set
167
168 (deftype md5-regs ()
169   "The working state of the MD5 algorithm, which contains the 4 32-bit
170 registers A, B, C and D."
171   `(simple-array (unsigned-byte 32) (4)))
172
173 (defmacro md5-regs-a (regs)
174   `(aref ,regs 0))
175
176 (defmacro md5-regs-b (regs)
177   `(aref ,regs 1))
178
179 (defmacro md5-regs-c (regs)
180   `(aref ,regs 2))
181
182 (defmacro md5-regs-d (regs)
183   `(aref ,regs 3))
184
185 (defconstant +md5-magic-a+ (assemble-ub32 #x01 #x23 #x45 #x67)
186   "Initial value of Register A of the MD5 working state.")
187 (defconstant +md5-magic-b+ (assemble-ub32 #x89 #xab #xcd #xef)
188   "Initial value of Register B of the MD5 working state.")
189 (defconstant +md5-magic-c+ (assemble-ub32 #xfe #xdc #xba #x98)
190   "Initial value of Register C of the MD5 working state.")
191 (defconstant +md5-magic-d+ (assemble-ub32 #x76 #x54 #x32 #x10)
192   "Initial value of Register D of the MD5 working state.")
193
194 (declaim (inline initial-md5-regs))
195 (defun initial-md5-regs ()
196   "Create the initial working state of an MD5 run."
197   (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)))
198   (let ((regs (make-array 4 :element-type '(unsigned-byte 32))))
199     (declare (type md5-regs regs))
200     (setf (md5-regs-a regs) +md5-magic-a+
201           (md5-regs-b regs) +md5-magic-b+
202           (md5-regs-c regs) +md5-magic-c+
203           (md5-regs-d regs) +md5-magic-d+)
204     regs))
205
206 ;;; Section 3.4:  Operation on 16-Word Blocks
207
208 (defun update-md5-block (regs block)
209   "This is the core part of the MD5 algorithm.  It takes a complete 16
210 word block of input, and updates the working state in A, B, C, and D
211 accordingly."
212   (declare (type md5-regs regs)
213            (type (simple-array ub32 (16)) block)
214            (optimize (speed 3) (safety 0) (space 0) (debug 0)))
215   (let ((a (md5-regs-a regs)) (b (md5-regs-b regs))
216         (c (md5-regs-c regs)) (d (md5-regs-d regs)))
217     (declare (type ub32 a b c d))
218     ;; Round 1
219     (with-md5-round (f block)
220       (A B C D  0  7  1)(D A B C  1 12  2)(C D A B  2 17  3)(B C D A  3 22  4)
221       (A B C D  4  7  5)(D A B C  5 12  6)(C D A B  6 17  7)(B C D A  7 22  8)
222       (A B C D  8  7  9)(D A B C  9 12 10)(C D A B 10 17 11)(B C D A 11 22 12)
223       (A B C D 12  7 13)(D A B C 13 12 14)(C D A B 14 17 15)(B C D A 15 22 16))
224     ;; Round 2
225     (with-md5-round (g block)
226       (A B C D  1  5 17)(D A B C  6  9 18)(C D A B 11 14 19)(B C D A  0 20 20)
227       (A B C D  5  5 21)(D A B C 10  9 22)(C D A B 15 14 23)(B C D A  4 20 24)
228       (A B C D  9  5 25)(D A B C 14  9 26)(C D A B  3 14 27)(B C D A  8 20 28)
229       (A B C D 13  5 29)(D A B C  2  9 30)(C D A B  7 14 31)(B C D A 12 20 32))
230     ;; Round 3
231     (with-md5-round (h block)
232       (A B C D  5  4 33)(D A B C  8 11 34)(C D A B 11 16 35)(B C D A 14 23 36)
233       (A B C D  1  4 37)(D A B C  4 11 38)(C D A B  7 16 39)(B C D A 10 23 40)
234       (A B C D 13  4 41)(D A B C  0 11 42)(C D A B  3 16 43)(B C D A  6 23 44)
235       (A B C D  9  4 45)(D A B C 12 11 46)(C D A B 15 16 47)(B C D A  2 23 48))
236     ;; Round 4
237     (with-md5-round (i block)
238       (A B C D  0  6 49)(D A B C  7 10 50)(C D A B 14 15 51)(B C D A  5 21 52)
239       (A B C D 12  6 53)(D A B C  3 10 54)(C D A B 10 15 55)(B C D A  1 21 56)
240       (A B C D  8  6 57)(D A B C 15 10 58)(C D A B  6 15 59)(B C D A 13 21 60)
241       (A B C D  4  6 61)(D A B C 11 10 62)(C D A B  2 15 63)(B C D A  9 21 64))
242     ;; Update and return
243     (setf (md5-regs-a regs) (mod32+ (md5-regs-a regs) a)
244           (md5-regs-b regs) (mod32+ (md5-regs-b regs) b)
245           (md5-regs-c regs) (mod32+ (md5-regs-c regs) c)
246           (md5-regs-d regs) (mod32+ (md5-regs-d regs) d))
247     regs))
248
249 ;;; Section 3.4:  Converting 8bit-vectors into 16-Word Blocks
250
251 (declaim (inline fill-block fill-block-ub8 fill-block-char))
252 (defun fill-block (block buffer offset)
253   "Convert a complete 64 byte input vector segment into the given 16
254 word MD5 block.  This currently works on (unsigned-byte 8) and
255 character simple-arrays, via the functions `fill-block-ub8' and
256 `fill-block-char' respectively."
257   (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset)
258            (type (simple-array ub32 (16)) block)
259            (type (simple-array * (*)) buffer)
260            (optimize (speed 3) (safety 0) (space 0) (debug 0)))
261   (etypecase buffer
262     ((simple-array (unsigned-byte 8) (*))
263      (fill-block-ub8 block buffer offset))
264     (simple-string
265      (fill-block-char block buffer offset))))
266
267 (defun fill-block-ub8 (block buffer offset)
268   "Convert a complete 64 (unsigned-byte 8) input vector segment
269 starting from offset into the given 16 word MD5 block."
270   (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset)
271            (type (simple-array ub32 (16)) block)
272            (type (simple-array (unsigned-byte 8) (*)) buffer)
273            (optimize (speed 3) (safety 0) (space 0) (debug 0)))
274   #+(and :cmu :little-endian)
275   (kernel:bit-bash-copy
276    buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits))
277    block (* vm:vector-data-offset vm:word-bits)
278    (* 64 vm:byte-bits))
279   #+(and :sbcl :little-endian)
280   (sb-kernel:ub8-bash-copy buffer offset block 0 64)
281   #-(or (and :sbcl :little-endian) (and :cmu :little-endian))
282   (loop for i of-type (integer 0 16) from 0
283         for j of-type (integer 0 #.most-positive-fixnum)
284         from offset to (+ offset 63) by 4
285         do
286         (setf (aref block i)
287               (assemble-ub32 (aref buffer j)
288                              (aref buffer (+ j 1))
289                              (aref buffer (+ j 2))
290                              (aref buffer (+ j 3))))))
291
292 (defun fill-block-char (block buffer offset)
293   "Convert a complete 64 character input string segment starting from
294 offset into the given 16 word MD5 block."
295   (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset)
296            (type (simple-array ub32 (16)) block)
297            (type simple-string buffer)
298            (optimize (speed 3) (safety 0) (space 0) (debug 0)))
299   #+(and :cmu :little-endian)
300   (kernel:bit-bash-copy
301    buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits))
302    block (* vm:vector-data-offset vm:word-bits)
303    (* 64 vm:byte-bits))
304   #+(and :sbcl :little-endian)
305   (sb-kernel:ub8-bash-copy buffer offset block 0 64)
306   #-(or (and :sbcl :little-endian) (and :cmu :little-endian))
307   (loop for i of-type (integer 0 16) from 0
308         for j of-type (integer 0 #.most-positive-fixnum)
309         from offset to (+ offset 63) by 4
310         do
311         (setf (aref block i)
312               (assemble-ub32 (char-code (schar buffer j))
313                              (char-code (schar buffer (+ j 1)))
314                              (char-code (schar buffer (+ j 2)))
315                              (char-code (schar buffer (+ j 3)))))))
316
317 ;;; Section 3.5:  Message Digest Output
318
319 (declaim (inline md5regs-digest))
320 (defun md5regs-digest (regs)
321   "Create the final 16 byte message-digest from the MD5 working state
322 in regs.  Returns a (simple-array (unsigned-byte 8) (16))."
323   (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))
324            (type md5-regs regs))
325   (let ((result (make-array 16 :element-type '(unsigned-byte 8))))
326     (declare (type (simple-array (unsigned-byte 8) (16)) result))
327     (macrolet ((frob (reg offset)
328                  (let ((var (gensym)))
329                    `(let ((,var ,reg))
330                       (declare (type ub32 ,var))
331                       (setf
332                        (aref result ,offset) (ldb (byte 8 0) ,var)
333                        (aref result ,(+ offset 1)) (ldb (byte 8 8) ,var)
334                        (aref result ,(+ offset 2)) (ldb (byte 8 16) ,var)
335                        (aref result ,(+ offset 3)) (ldb (byte 8 24) ,var))))))
336       (frob (md5-regs-a regs) 0)
337       (frob (md5-regs-b regs) 4)
338       (frob (md5-regs-c regs) 8)
339       (frob (md5-regs-d regs) 12))
340     result))
341
342 ;;; Mid-Level Drivers
343
344 (defstruct (md5-state
345              (:constructor make-md5-state ())
346              (:copier))
347   (regs (initial-md5-regs) :type md5-regs :read-only t)
348   (amount 0 :type
349           #-md5-small-length (integer 0 *)
350           #+md5-small-length (unsigned-byte 29))
351   (block (make-array 16 :element-type '(unsigned-byte 32)) :read-only t
352          :type (simple-array (unsigned-byte 32) (16)))
353   (buffer (make-array 64 :element-type '(unsigned-byte 8)) :read-only t
354          :type (simple-array (unsigned-byte 8) (64)))
355   (buffer-index 0 :type (integer 0 63))
356   (finalized-p nil))
357
358 (declaim (inline copy-to-buffer))
359 (defun copy-to-buffer (from from-offset count buffer buffer-offset)
360   "Copy a partial segment from input vector from starting at
361 from-offset and copying count elements into the 64 byte buffer
362 starting at buffer-offset."
363   (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))
364            (type (unsigned-byte 29) from-offset)
365            (type (integer 0 63) count buffer-offset)
366            (type (simple-array * (*)) from)
367            (type (simple-array (unsigned-byte 8) (64)) buffer))
368   #+cmu
369   (kernel:bit-bash-copy
370    from (+ (* vm:vector-data-offset vm:word-bits) (* from-offset vm:byte-bits))
371    buffer (+ (* vm:vector-data-offset vm:word-bits)
372              (* buffer-offset vm:byte-bits))
373    (* count vm:byte-bits))
374   #+sbcl
375   (sb-kernel:ub8-bash-copy from from-offset buffer buffer-offset count)
376   #-(or cmu sbcl)
377   (etypecase from
378     (simple-string
379      (loop for buffer-index of-type (integer 0 64) from buffer-offset
380            for from-index of-type fixnum from from-offset
381            below (+ from-offset count)
382            do
383            (setf (aref buffer buffer-index)
384                  (char-code (schar (the simple-string from) from-index)))))
385     ((simple-array (unsigned-byte 8) (*))
386      (loop for buffer-index of-type (integer 0 64) from buffer-offset
387            for from-index of-type fixnum from from-offset
388            below (+ from-offset count)
389            do
390            (setf (aref buffer buffer-index)
391                  (aref (the (simple-array (unsigned-byte 8) (*)) from)
392                        from-index))))))
393
394 (defun update-md5-state (state sequence &key (start 0) (end (length sequence)))
395   "Update the given md5-state from sequence, which is either a
396 simple-string or a simple-array with element-type (unsigned-byte 8),
397 bounded by start and end, which must be numeric bounding-indices."
398   (declare (type md5-state state)
399            (type (simple-array * (*)) sequence)
400            (type fixnum start end)
401            (optimize (speed 3) #+(or cmu sbcl) (safety 0) (space 0) (debug 0))
402            #+cmu
403            (ext:optimize-interface (safety 1) (debug 1)))
404   (let ((regs (md5-state-regs state))
405         (block (md5-state-block state))
406         (buffer (md5-state-buffer state))
407         (buffer-index (md5-state-buffer-index state))
408         (length (- end start)))
409     (declare (type md5-regs regs) (type fixnum length)
410              (type (integer 0 63) buffer-index)
411              (type (simple-array (unsigned-byte 32) (16)) block)
412              (type (simple-array (unsigned-byte 8) (64)) buffer))
413     ;; Handle old rest
414     (unless (zerop buffer-index)
415       (let ((amount (min (- 64 buffer-index) length)))
416         (declare (type (integer 0 63) amount))
417         (copy-to-buffer sequence start amount buffer buffer-index)
418         (setq start (the fixnum (+ start amount)))
419         (let ((new-index (mod (+ buffer-index amount) 64)))
420           (when (zerop new-index)
421             (fill-block-ub8 block buffer 0)
422             (update-md5-block regs block))
423           (when (>= start end)
424             (setf (md5-state-buffer-index state) new-index)
425             (incf (md5-state-amount state) length)
426             (return-from update-md5-state state)))))
427     ;; Handle main-part and new-rest
428     (etypecase sequence
429       ((simple-array (unsigned-byte 8) (*))
430        (locally
431            (declare (type (simple-array (unsigned-byte 8) (*)) sequence))
432          (loop for offset of-type (unsigned-byte 29) from start below end by 64
433                until (< (- end offset) 64)
434                do
435                (fill-block-ub8 block sequence offset)
436                (update-md5-block regs block)
437                finally
438                (let ((amount (- end offset)))
439                  (unless (zerop amount)
440                    (copy-to-buffer sequence offset amount buffer 0))
441                  (setf (md5-state-buffer-index state) amount)))))
442       (simple-string
443        (locally
444            (declare (type simple-string sequence))
445          (loop for offset of-type (unsigned-byte 29) from start below end by 64
446                until (< (- end offset) 64)
447                do
448                (fill-block-char block sequence offset)
449                (update-md5-block regs block)
450                finally
451                (let ((amount (- end offset)))
452                  (unless (zerop amount)
453                    (copy-to-buffer sequence offset amount buffer 0))
454                  (setf (md5-state-buffer-index state) amount))))))
455     (setf (md5-state-amount state)
456           #-md5-small-length (+ (md5-state-amount state) length)
457           #+md5-small-length (the (unsigned-byte 29)
458                                (+ (md5-state-amount state) length)))
459     state))
460
461 (defun finalize-md5-state (state)
462   "If the given md5-state has not already been finalized, finalize it,
463 by processing any remaining input in its buffer, with suitable padding
464 and appended bit-length, as specified by the MD5 standard.
465
466 The resulting MD5 message-digest is returned as an array of sixteen
467 (unsigned-byte 8) values.  Calling `update-md5-state' after a call to
468 `finalize-md5-state' results in unspecified behaviour."
469   (declare (type md5-state state)
470            (optimize (speed 3) #+(or cmu sbcl) (safety 0) (space 0) (debug 0))
471            #+cmu
472            (ext:optimize-interface (safety 1) (debug 1)))
473   (or (md5-state-finalized-p state)
474       (let ((regs (md5-state-regs state))
475             (block (md5-state-block state))
476             (buffer (md5-state-buffer state))
477             (buffer-index (md5-state-buffer-index state))
478             (total-length (* 8 (md5-state-amount state))))
479         (declare (type md5-regs regs)
480                  (type (integer 0 63) buffer-index)
481                  (type (simple-array ub32 (16)) block)
482                  (type (simple-array (unsigned-byte 8) (*)) buffer))
483         ;; Add mandatory bit 1 padding
484         (setf (aref buffer buffer-index) #x80)
485         ;; Fill with 0 bit padding
486         (loop for index of-type (integer 0 64)
487               from (1+ buffer-index) below 64
488               do (setf (aref buffer index) #x00))
489         (fill-block-ub8 block buffer 0)
490         ;; Flush block first if length wouldn't fit
491         (when (>= buffer-index 56)
492           (update-md5-block regs block)
493           ;; Create new fully 0 padded block
494           (loop for index of-type (integer 0 16) from 0 below 16
495                 do (setf (aref block index) #x00000000)))
496         ;; Add 64bit message bit length
497         (setf (aref block 14) (ldb (byte 32 0) total-length))
498         #-md5-small-length
499         (setf (aref block 15) (ldb (byte 32 32) total-length))
500         ;; Flush last block
501         (update-md5-block regs block)
502         ;; Done, remember digest for later calls
503         (setf (md5-state-finalized-p state)
504               (md5regs-digest regs)))))
505
506 ;;; High-Level Drivers
507
508 (defun md5sum-sequence (sequence &key (start 0) end)
509   "Calculate the MD5 message-digest of data bounded by START and END
510 in SEQUENCE , which must be a vector with element-type (UNSIGNED-BYTE
511 8)."
512   (declare (optimize (speed 3) (safety 3) (space 0) (debug 1))
513            (type (vector (unsigned-byte 8)) sequence) (type fixnum start))
514   (locally
515     (declare (optimize (safety 1) (debug 0)))
516     (let ((state (make-md5-state)))
517       (declare (type md5-state state))
518       #+cmu
519       ;; respect the fill pointer
520       (let ((end (or end (length sequence))))
521         (lisp::with-array-data ((data sequence) (real-start start) (real-end end))
522           (declare (ignore real-end))
523           (update-md5-state state data :start real-start
524                             :end (+ real-start (- end start)))))
525       #+sbcl
526       ;; respect the fill pointer
527       (let ((end (or end (length sequence))))
528         (sb-kernel:with-array-data ((data sequence)
529                                     (real-start start)
530                                     (real-end end)
531                                     :check-fill-pointer t)
532           (declare (ignore real-end))
533           (update-md5-state state data :start real-start
534                             :end (+ real-start (- end start)))))
535       #-(or cmu sbcl)
536       (let ((real-end (or end (length sequence))))
537         (declare (type fixnum real-end))
538         (update-md5-state state sequence :start start :end real-end))
539       (finalize-md5-state state))))
540
541 (defun md5sum-string (string &key (external-format :default) (start 0) end)
542   "Calculate the MD5 message-digest of the binary representation
543 of STRING (as octets) in EXTERNAL-FORMAT. The boundaries START
544 and END refer to character positions in the string, not to octets
545 in the resulting binary representation."
546   (declare (optimize (speed 3) (safety 3) (space 0) (debug 1))
547            (type string string) (type fixnum start))
548   (locally
549     (declare (optimize (safety 1) (debug 0)))
550     (md5sum-sequence
551      (sb-ext:string-to-octets string
552                               :external-format external-format
553                               :start start :end end))))
554
555 (defconstant +buffer-size+ (* 128 1024)
556   "Size of internal buffer to use for md5sum-stream and md5sum-file
557 operations.  This should be a multiple of 64, the MD5 block size.")
558
559 (deftype buffer-index () `(integer 0 ,+buffer-size+))
560
561 (defun md5sum-stream (stream)
562   "Calculate an MD5 message-digest of the contents of STREAM, whose
563 element-type has to be (UNSIGNED-BYTE 8)."
564   (declare (optimize (speed 3) (safety 3) (space 0) (debug 1)))
565   (declare (type stream stream))
566   (locally
567     (declare (optimize (safety 1) (debug 0)))
568     (let ((state (make-md5-state)))
569       (declare (type md5-state state))
570       (cond
571         ((equal (stream-element-type stream) '(unsigned-byte 8))
572          (let ((buffer (make-array +buffer-size+
573                                    :element-type '(unsigned-byte 8))))
574            (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+))
575                           buffer))
576            (loop for bytes of-type buffer-index = (read-sequence buffer stream)
577                  do (update-md5-state state buffer :end bytes)
578                  until (< bytes +buffer-size+)
579                  finally
580                  (return (finalize-md5-state state)))))
581         #+(or)
582         ((equal (stream-element-type stream) 'character)
583          (let ((buffer (make-string +buffer-size+)))
584            (declare (type (simple-string #.+buffer-size+) buffer))
585            (loop for bytes of-type buffer-index = (read-sequence buffer stream)
586                  do (update-md5-state state buffer :end bytes)
587                  until (< bytes +buffer-size+)
588                  finally
589                  (return (finalize-md5-state state)))))
590         (t
591          (error "Unsupported stream element-type ~S for stream ~S."
592                 (stream-element-type stream) stream))))))
593
594 (defun md5sum-file (pathname)
595   "Calculate the MD5 message-digest of the file designated by
596 pathname."
597   (declare (optimize (speed 3) (safety 3) (space 0) (debug 1)))
598   (locally
599     (declare (optimize (safety 1) (debug 0)))
600     (with-open-file (stream pathname :element-type '(unsigned-byte 8))
601       (md5sum-stream stream))))
602
603 #+cmu
604 (eval-when (:compile-toplevel :execute)
605   (setq *features* *old-features*))
606
607 #+cmu
608 (eval-when (:compile-toplevel)
609   (setq ext:*inline-expansion-limit* *old-expansion-limit*))
610
611 #+sbcl
612 (eval-when (:compile-toplevel)
613   (setq *features* *old-features*))