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*))