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:bit-bash-copy
 281    buffer (+ (* sb-vm:vector-data-offset sb-vm:n-word-bits)
 282              (* offset sb-vm:n-byte-bits))
 283    block (* sb-vm:vector-data-offset sb-vm:n-word-bits)
 284    (* 64 sb-vm:n-byte-bits))
 285   #-(or (and :sbcl :little-endian) (and :cmu :little-endian))
 286   (loop for i of-type (integer 0 16) from 0
 287         for j of-type (integer 0 #.most-positive-fixnum)
 288         from offset to (+ offset 63) by 4
 289         do
 290         (setf (aref block i)
 291               (assemble-ub32 (aref buffer j)
 292                              (aref buffer (+ j 1))
 293                              (aref buffer (+ j 2))
 294                              (aref buffer (+ j 3))))))
 295
 296 (defun fill-block-char (block buffer offset)
 297   "Convert a complete 64 character input string segment starting from
 298 offset into the given 16 word MD5 block."
 299   (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset)
 300            (type (simple-array ub32 (16)) block)
 301            (type simple-string buffer)
 302            (optimize (speed 3) (safety 0) (space 0) (debug 0)))
 303   #+(and :cmu :little-endian)
 304   (kernel:bit-bash-copy
 305    buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits))
 306    block (* vm:vector-data-offset vm:word-bits)
 307    (* 64 vm:byte-bits))
 308   #+(and :sbcl :little-endian)
 309   (sb-kernel:bit-bash-copy
 310    buffer (+ (* sb-vm:vector-data-offset sb-vm:n-word-bits)
 311              (* offset sb-vm:n-byte-bits))
 312    block (* sb-vm:vector-data-offset sb-vm:n-word-bits)
 313    (* 64 sb-vm:n-byte-bits))
 314   #-(or (and :sbcl :little-endian) (and :cmu :little-endian))
 315   (loop for i of-type (integer 0 16) from 0
 316         for j of-type (integer 0 #.most-positive-fixnum)
 317         from offset to (+ offset 63) by 4
 318         do
 319         (setf (aref block i)
 320               (assemble-ub32 (char-code (schar buffer j))
 321                              (char-code (schar buffer (+ j 1)))
 322                              (char-code (schar buffer (+ j 2)))
 323                              (char-code (schar buffer (+ j 3)))))))
 324
 325 ;;; Section 3.5:  Message Digest Output
 326
 327 (declaim (inline md5regs-digest))
 328 (defun md5regs-digest (regs)
 329   "Create the final 16 byte message-digest from the MD5 working state
 330 in regs.  Returns a (simple-array (unsigned-byte 8) (16))."
 331   (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))
 332            (type md5-regs regs))
 333   (let ((result (make-array 16 :element-type '(unsigned-byte 8))))
 334     (declare (type (simple-array (unsigned-byte 8) (16)) result))
 335     (macrolet ((frob (reg offset)
 336                  (let ((var (gensym)))
 337                    `(let ((,var ,reg))
 338                       (declare (type ub32 ,var))
 339                       (setf
 340                        (aref result ,offset) (ldb (byte 8 0) ,var)
 341                        (aref result ,(+ offset 1)) (ldb (byte 8 8) ,var)
 342                        (aref result ,(+ offset 2)) (ldb (byte 8 16) ,var)
 343                        (aref result ,(+ offset 3)) (ldb (byte 8 24) ,var))))))
 344       (frob (md5-regs-a regs) 0)
 345       (frob (md5-regs-b regs) 4)
 346       (frob (md5-regs-c regs) 8)
 347       (frob (md5-regs-d regs) 12))
 348     result))
 349
 350 ;;; Mid-Level Drivers
 351
 352 (defstruct (md5-state
 353              (:constructor make-md5-state ())
 354              (:copier))
 355   (regs (initial-md5-regs) :type md5-regs :read-only t)
 356   (amount 0 :type
 357           #-md5-small-length (integer 0 *)
 358           #+md5-small-length (unsigned-byte 29))
 359   (block (make-array 16 :element-type '(unsigned-byte 32)) :read-only t
 360          :type (simple-array (unsigned-byte 32) (16)))
 361   (buffer (make-array 64 :element-type '(unsigned-byte 8)) :read-only t
 362          :type (simple-array (unsigned-byte 8) (64)))
 363   (buffer-index 0 :type (integer 0 63))
 364   (finalized-p nil))
 365
 366 (declaim (inline copy-to-buffer))
 367 (defun copy-to-buffer (from from-offset count buffer buffer-offset)
 368   "Copy a partial segment from input vector from starting at
 369 from-offset and copying count elements into the 64 byte buffer
 370 starting at buffer-offset."
 371   (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))
 372            (type (unsigned-byte 29) from-offset)
 373            (type (integer 0 63) count buffer-offset)
 374            (type (simple-array * (*)) from)
 375            (type (simple-array (unsigned-byte 8) (64)) buffer))
 376   #+cmu
 377   (kernel:bit-bash-copy
 378    from (+ (* vm:vector-data-offset vm:word-bits) (* from-offset vm:byte-bits))
 379    buffer (+ (* vm:vector-data-offset vm:word-bits)
 380              (* buffer-offset vm:byte-bits))
 381    (* count vm:byte-bits))
 382   #+sbcl
 383   (sb-kernel:bit-bash-copy
 384    from (+ (* sb-vm:vector-data-offset sb-vm:n-word-bits)
 385            (* from-offset sb-vm:n-byte-bits))
 386    buffer (+ (* sb-vm:vector-data-offset sb-vm:n-word-bits)
 387              (* buffer-offset sb-vm:n-byte-bits))
 388    (* count sb-vm:n-byte-bits))
 389   #-(or cmu sbcl)
 390   (etypecase from
 391     (simple-string
 392      (loop for buffer-index of-type (integer 0 64) from buffer-offset
 393            for from-index of-type fixnum from from-offset
 394            below (+ from-offset count)
 395            do
 396            (setf (aref buffer buffer-index)
 397                  (char-code (schar (the simple-string from) from-index)))))
 398     ((simple-array (unsigned-byte 8) (*))
 399      (loop for buffer-index of-type (integer 0 64) from buffer-offset
 400            for from-index of-type fixnum from from-offset
 401            below (+ from-offset count)
 402            do
 403            (setf (aref buffer buffer-index)
 404                  (aref (the (simple-array (unsigned-byte 8) (*)) from)
 405                        from-index))))))
 406
 407 (defun update-md5-state (state sequence &key (start 0) (end (length sequence)))
 408   "Update the given md5-state from sequence, which is either a
 409 simple-string or a simple-array with element-type (unsigned-byte 8),
 410 bounded by start and end, which must be numeric bounding-indices."
 411   (declare (type md5-state state)
 412            (type (simple-array * (*)) sequence)
 413            (type fixnum start end)
 414            (optimize (speed 3) #+(or cmu sbcl) (safety 0) (space 0) (debug 0))
 415            #+cmu
 416            (ext:optimize-interface (safety 1) (debug 1)))
 417   (let ((regs (md5-state-regs state))
 418         (block (md5-state-block state))
 419         (buffer (md5-state-buffer state))
 420         (buffer-index (md5-state-buffer-index state))
 421         (length (- end start)))
 422     (declare (type md5-regs regs) (type fixnum length)
 423              (type (integer 0 63) buffer-index)
 424              (type (simple-array (unsigned-byte 32) (16)) block)
 425              (type (simple-array (unsigned-byte 8) (64)) buffer))
 426     ;; Handle old rest
 427     (unless (zerop buffer-index)
 428       (let ((amount (min (- 64 buffer-index) length)))
 429         (declare (type (integer 0 63) amount))
 430         (copy-to-buffer sequence start amount buffer buffer-index)
 431         (setq start (the fixnum (+ start amount)))
 432         (when (>= start end)
 433           (setf (md5-state-buffer-index state) (+ buffer-index amount))
 434           (return-from update-md5-state state)))
 435       (fill-block-ub8 block buffer 0)
 436       (update-md5-block regs block))
 437     ;; Handle main-part and new-rest
 438     (etypecase sequence
 439       ((simple-array (unsigned-byte 8) (*))
 440        (locally
 441            (declare (type (simple-array (unsigned-byte 8) (*)) 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-ub8 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       (simple-string
 453        (locally
 454            (declare (type simple-string sequence))
 455          (loop for offset of-type (unsigned-byte 29) from start below end by 64
 456                until (< (- end offset) 64)
 457                do
 458                (fill-block-char block sequence offset)
 459                (update-md5-block regs block)
 460                finally
 461                (let ((amount (- end offset)))
 462                  (unless (zerop amount)
 463                    (copy-to-buffer sequence offset amount buffer 0))
 464                  (setf (md5-state-buffer-index state) amount))))))
 465     (setf (md5-state-amount state)
 466           #-md5-small-length (+ (md5-state-amount state) length)
 467           #+md5-small-length (the (unsigned-byte 29)
 468                                (+ (md5-state-amount state) length)))
 469     state))
 470
 471 (defun finalize-md5-state (state)
 472   "If the given md5-state has not already been finalized, finalize it,
 473 by processing any remaining input in its buffer, with suitable padding
 474 and appended bit-length, as specified by the MD5 standard.
 475
 476 The resulting MD5 message-digest is returned as an array of sixteen
 477 (unsigned-byte 8) values.  Calling `update-md5-state' after a call to
 478 `finalize-md5-state' results in unspecified behaviour."
 479   (declare (type md5-state state)
 480            (optimize (speed 3) #+(or cmu sbcl) (safety 0) (space 0) (debug 0))
 481            #+cmu
 482            (ext:optimize-interface (safety 1) (debug 1)))
 483   (or (md5-state-finalized-p state)
 484       (let ((regs (md5-state-regs state))
 485             (block (md5-state-block state))
 486             (buffer (md5-state-buffer state))
 487             (buffer-index (md5-state-buffer-index state))
 488             (total-length (* 8 (md5-state-amount state))))
 489         (declare (type md5-regs regs)
 490                  (type (integer 0 63) buffer-index)
 491                  (type (simple-array ub32 (16)) block)
 492                  (type (simple-array (unsigned-byte 8) (*)) buffer))
 493         ;; Add mandatory bit 1 padding
 494         (setf (aref buffer buffer-index) #x80)
 495         ;; Fill with 0 bit padding
 496         (loop for index of-type (integer 0 64)
 497               from (1+ buffer-index) below 64
 498               do (setf (aref buffer index) #x00))
 499         (fill-block-ub8 block buffer 0)
 500         ;; Flush block first if length wouldn't fit
 501         (when (>= buffer-index 56)
 502           (update-md5-block regs block)
 503           ;; Create new fully 0 padded block
 504           (loop for index of-type (integer 0 16) from 0 below 16
 505                 do (setf (aref block index) #x00000000)))
 506         ;; Add 64bit message bit length
 507         (setf (aref block 14) (ldb (byte 32 0) total-length))
 508         #-md5-small-length
 509         (setf (aref block 15) (ldb (byte 32 32) total-length))
 510         ;; Flush last block
 511         (update-md5-block regs block)
 512         ;; Done, remember digest for later calls
 513         (setf (md5-state-finalized-p state)
 514               (md5regs-digest regs)))))
 515
 516 ;;; High-Level Drivers
 517
 518 (defun md5sum-sequence (sequence &key (start 0) end)
 519   "Calculate the MD5 message-digest of data bounded by START and END
 520 in SEQUENCE , which must be a vector with element-type (UNSIGNED-BYTE
 521 8)."
 522   (declare (optimize (speed 3) (space 0) (debug 0))
 523            (type vector sequence) (type fixnum start))
 524   (let ((state (make-md5-state)))
 525     (declare (type md5-state state))
 526     #+cmu
 527     (lisp::with-array-data ((data sequence) (real-start start) (real-end end))
 528       (update-md5-state state data :start real-start :end real-end))
 529     #+sbcl
 530     (sb-kernel:with-array-data ((data sequence) (real-start start) (real-end end))
 531       (update-md5-state state data :start real-start :end real-end))
 532     #-(or cmu sbcl)
 533     (let ((real-end (or end (length sequence))))
 534       (declare (type fixnum real-end))
 535       (update-md5-state state sequence :start start :end real-end))
 536     (finalize-md5-state state)))
 537
 538 (defun md5sum-string (string &key (external-format :default) (start 0) end)
 539   "Calculate the MD5 message-digest of the binary representation
 540 of STRING (as octets) in EXTERNAL-FORMAT. The boundaries START
 541 and END refer to character positions in the string, not to octets
 542 in the resulting binary representation."
 543   (declare (optimize (speed 3) (space 0) (debug 0))
 544            (type string string))
 545   (md5sum-sequence
 546    (sb-ext:string-to-octets string
 547                             :external-format external-format
 548                             :start start :end end)))
 549
 550 (defconstant +buffer-size+ (* 128 1024)
 551   "Size of internal buffer to use for md5sum-stream and md5sum-file
 552 operations.  This should be a multiple of 64, the MD5 block size.")
 553
 554 (deftype buffer-index () `(integer 0 ,+buffer-size+))
 555
 556 (defun md5sum-stream (stream)
 557   "Calculate an MD5 message-digest of the contents of STREAM, whose
 558 element-type has to be (UNSIGNED-BYTE 8)."
 559   (declare (optimize (speed 3) (space 0) (debug 0)))
 560   (let ((state (make-md5-state)))
 561     (declare (type md5-state state))
 562     (cond
 563       ((equal (stream-element-type stream) '(unsigned-byte 8))
 564        (let ((buffer (make-array +buffer-size+
 565                                  :element-type '(unsigned-byte 8))))
 566          (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+))
 567                         buffer))
 568          (loop for bytes of-type buffer-index = (read-sequence buffer stream)
 569                do (update-md5-state state buffer :end bytes)
 570                until (< bytes +buffer-size+)
 571                finally
 572                (return (finalize-md5-state state)))))
 573       ((equal (stream-element-type stream) 'character)
 574        (let ((buffer (make-string +buffer-size+)))
 575          (declare (type (simple-string #.+buffer-size+) 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       (t
 582        (error "Unsupported stream element-type ~S for stream ~S."
 583               (stream-element-type stream) stream)))))
 584
 585 (defun md5sum-file (pathname)
 586   "Calculate the MD5 message-digest of the file specified by pathname."
 587   (declare (optimize (speed 3) (space 0) (debug 0)))
 588   (with-open-file (stream pathname :element-type '(unsigned-byte 8))
 589     (md5sum-stream stream)))
 590
 591 #+cmu
 592 (eval-when (:compile-toplevel :execute)
 593   (setq *features* *old-features*))
 594
 595 #+cmu
 596 (eval-when (:compile-toplevel)
 597   (setq ext:*inline-expansion-limit* *old-expansion-limit*))
 598
 599 #+sbcl
 600 (eval-when (:compile-toplevel)
 601   (setq *features* *old-features*))