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         (when (>= start end)
 420           (setf (md5-state-buffer-index state) (+ buffer-index amount))
 421           (return-from update-md5-state state)))
 422       (fill-block-ub8 block buffer 0)
 423       (update-md5-block regs block))
 424     ;; Handle main-part and new-rest
 425     (etypecase sequence
 426       ((simple-array (unsigned-byte 8) (*))
 427        (locally
 428            (declare (type (simple-array (unsigned-byte 8) (*)) sequence))
 429          (loop for offset of-type (unsigned-byte 29) from start below end by 64
 430                until (< (- end offset) 64)
 431                do
 432                (fill-block-ub8 block sequence offset)
 433                (update-md5-block regs block)
 434                finally
 435                (let ((amount (- end offset)))
 436                  (unless (zerop amount)
 437                    (copy-to-buffer sequence offset amount buffer 0))
 438                  (setf (md5-state-buffer-index state) amount)))))
 439       (simple-string
 440        (locally
 441            (declare (type simple-string sequence))
 442          (loop for offset of-type (unsigned-byte 29) from start below end by 64
 443                until (< (- end offset) 64)
 444                do
 445                (fill-block-char block sequence offset)
 446                (update-md5-block regs block)
 447                finally
 448                (let ((amount (- end offset)))
 449                  (unless (zerop amount)
 450                    (copy-to-buffer sequence offset amount buffer 0))
 451                  (setf (md5-state-buffer-index state) amount))))))
 452     (setf (md5-state-amount state)
 453           #-md5-small-length (+ (md5-state-amount state) length)
 454           #+md5-small-length (the (unsigned-byte 29)
 455                                (+ (md5-state-amount state) length)))
 456     state))
 457
 458 (defun finalize-md5-state (state)
 459   "If the given md5-state has not already been finalized, finalize it,
 460 by processing any remaining input in its buffer, with suitable padding
 461 and appended bit-length, as specified by the MD5 standard.
 462
 463 The resulting MD5 message-digest is returned as an array of sixteen
 464 (unsigned-byte 8) values.  Calling `update-md5-state' after a call to
 465 `finalize-md5-state' results in unspecified behaviour."
 466   (declare (type md5-state state)
 467            (optimize (speed 3) #+(or cmu sbcl) (safety 0) (space 0) (debug 0))
 468            #+cmu
 469            (ext:optimize-interface (safety 1) (debug 1)))
 470   (or (md5-state-finalized-p state)
 471       (let ((regs (md5-state-regs state))
 472             (block (md5-state-block state))
 473             (buffer (md5-state-buffer state))
 474             (buffer-index (md5-state-buffer-index state))
 475             (total-length (* 8 (md5-state-amount state))))
 476         (declare (type md5-regs regs)
 477                  (type (integer 0 63) buffer-index)
 478                  (type (simple-array ub32 (16)) block)
 479                  (type (simple-array (unsigned-byte 8) (*)) buffer))
 480         ;; Add mandatory bit 1 padding
 481         (setf (aref buffer buffer-index) #x80)
 482         ;; Fill with 0 bit padding
 483         (loop for index of-type (integer 0 64)
 484               from (1+ buffer-index) below 64
 485               do (setf (aref buffer index) #x00))
 486         (fill-block-ub8 block buffer 0)
 487         ;; Flush block first if length wouldn't fit
 488         (when (>= buffer-index 56)
 489           (update-md5-block regs block)
 490           ;; Create new fully 0 padded block
 491           (loop for index of-type (integer 0 16) from 0 below 16
 492                 do (setf (aref block index) #x00000000)))
 493         ;; Add 64bit message bit length
 494         (setf (aref block 14) (ldb (byte 32 0) total-length))
 495         #-md5-small-length
 496         (setf (aref block 15) (ldb (byte 32 32) total-length))
 497         ;; Flush last block
 498         (update-md5-block regs block)
 499         ;; Done, remember digest for later calls
 500         (setf (md5-state-finalized-p state)
 501               (md5regs-digest regs)))))
 502
 503 ;;; High-Level Drivers
 504
 505 (defun md5sum-sequence (sequence &key (start 0) end)
 506   "Calculate the MD5 message-digest of data bounded by START and END
 507 in SEQUENCE , which must be a vector with element-type (UNSIGNED-BYTE
 508 8)."
 509   (declare (optimize (speed 3) (safety 3) (space 0) (debug 1))
 510            (type (vector (unsigned-byte 8)) sequence) (type fixnum start))
 511   (locally
 512     (declare (optimize (safety 1) (debug 0)))
 513     (let ((state (make-md5-state)))
 514       (declare (type md5-state state))
 515       #+cmu
 516       (lisp::with-array-data ((data sequence) (real-start start) (real-end end))
 517         (update-md5-state state data :start real-start :end real-end))
 518       #+sbcl
 519       (sb-kernel:with-array-data ((data sequence) (real-start start) (real-end end))
 520         (update-md5-state state data :start real-start :end real-end))
 521       #-(or cmu sbcl)
 522       (let ((real-end (or end (length sequence))))
 523         (declare (type fixnum real-end))
 524         (update-md5-state state sequence :start start :end real-end))
 525       (finalize-md5-state state))))
 526
 527 (defun md5sum-string (string &key (external-format :default) (start 0) end)
 528   "Calculate the MD5 message-digest of the binary representation
 529 of STRING (as octets) in EXTERNAL-FORMAT. The boundaries START
 530 and END refer to character positions in the string, not to octets
 531 in the resulting binary representation."
 532   (declare (optimize (speed 3) (safety 3) (space 0) (debug 1))
 533            (type string string) (type fixnum start))
 534   (locally
 535     (declare (optimize (safety 1) (debug 0)))
 536     (md5sum-sequence
 537      (sb-ext:string-to-octets string
 538                               :external-format external-format
 539                               :start start :end end))))
 540
 541 (defconstant +buffer-size+ (* 128 1024)
 542   "Size of internal buffer to use for md5sum-stream and md5sum-file
 543 operations.  This should be a multiple of 64, the MD5 block size.")
 544
 545 (deftype buffer-index () `(integer 0 ,+buffer-size+))
 546
 547 (defun md5sum-stream (stream)
 548   "Calculate an MD5 message-digest of the contents of STREAM, whose
 549 element-type has to be (UNSIGNED-BYTE 8)."
 550   (declare (optimize (speed 3) (safety 3) (space 0) (debug 1)))
 551   (declare (type stream stream))
 552   (locally
 553     (declare (optimize (safety 1) (debug 0)))
 554     (let ((state (make-md5-state)))
 555       (declare (type md5-state state))
 556       (cond
 557         ((equal (stream-element-type stream) '(unsigned-byte 8))
 558          (let ((buffer (make-array +buffer-size+
 559                                    :element-type '(unsigned-byte 8))))
 560            (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+))
 561                           buffer))
 562            (loop for bytes of-type buffer-index = (read-sequence buffer stream)
 563                  do (update-md5-state state buffer :end bytes)
 564                  until (< bytes +buffer-size+)
 565                  finally
 566                  (return (finalize-md5-state state)))))
 567         #+(or)
 568         ((equal (stream-element-type stream) 'character)
 569          (let ((buffer (make-string +buffer-size+)))
 570            (declare (type (simple-string #.+buffer-size+) buffer))
 571            (loop for bytes of-type buffer-index = (read-sequence buffer stream)
 572                  do (update-md5-state state buffer :end bytes)
 573                  until (< bytes +buffer-size+)
 574                  finally
 575                  (return (finalize-md5-state state)))))
 576         (t
 577          (error "Unsupported stream element-type ~S for stream ~S."
 578                 (stream-element-type stream) stream))))))
 579
 580 (defun md5sum-file (pathname)
 581   "Calculate the MD5 message-digest of the file designated by
 582 pathname."
 583   (declare (optimize (speed 3) (safety 3) (space 0) (debug 1)))
 584   (locally
 585     (declare (optimize (safety 1) (debug 0)))
 586     (with-open-file (stream pathname :element-type '(unsigned-byte 8))
 587       (md5sum-stream stream))))
 588
 589 #+cmu
 590 (eval-when (:compile-toplevel :execute)
 591   (setq *features* *old-features*))
 592
 593 #+cmu
 594 (eval-when (:compile-toplevel)
 595   (setq ext:*inline-expansion-limit* *old-expansion-limit*))
 596
 597 #+sbcl
 598 (eval-when (:compile-toplevel)
 599   (setq *features* *old-features*))