Fixed a stupid thinko in the padding routine, as reported by Edi Weitz.

Since the code in question was needlessly convoluted, rewrote those
sections to make them clearer.  Added another test-suite to test whether
padding works correctly, when compared with md5sum.

src/md5.lisp

@@ -31,6 +31,8 @@
 ;;;; *features* prior to compilation.  In that case evaluating
 ;;;; (md5::test-rfc1321) will run all the test-cases present in
 ;;;; Appendix A.5 of RFC 1321 and report on the results.
+;;;; Evaluating (md5::test-other) will run further test-cases
+;;;; gathered by the author to cover regressions, etc.
 ;;;;
 ;;;; This software is "as is", and has no warranty of any kind.  The
 ;;;; authors assume no responsibility for the consequences of any use
@@ -463,23 +465,26 @@ The resulting MD5 message-digest is returned as an array of sixteen
 		 (type (integer 0 63) buffer-index)
 		 (type (simple-array ub32 (16)) block)
 		 (type (simple-array (unsigned-byte 8) (*)) buffer))
+	;; Add mandatory bit 1 padding
 	(setf (aref buffer buffer-index) #x80)
+	;; Fill with 0 bit padding
 	(loop for index of-type (integer 0 64)
 	      from (1+ buffer-index) below 64
 	      do (setf (aref buffer index) #x00))
 	(fill-block-ub8 block buffer 0)
-	(when (< buffer-index 56)
-	  (setf (aref block 14) (ldb (byte 32 0) total-length))
-	  #-md5-small-length
-	  (setf (aref block 15) (ldb (byte 32 32) total-length)))
-	(update-md5-block regs block)
-	(when (< 56 buffer-index 64)
+	;; Flush block first if length wouldn't fit
+	(when (>= buffer-index 56)
+	  (update-md5-block regs block)
+	  ;; Create new fully 0 padded block
 	  (loop for index of-type (integer 0 16) from 0 below 16
-		do (setf (aref block index) #x00000000))
-	  (setf (aref block 14) (ldb (byte 32 0) total-length))
-	  #-md5-small-length
-	  (setf (aref block 15) (ldb (byte 32 32) total-length))
-	  (update-md5-block regs block))
+		do (setf (aref block index) #x00000000)))
+	;; Add 64bit message bit length
+	(setf (aref block 14) (ldb (byte 32 0) total-length))
+	#-md5-small-length
+	(setf (aref block 15) (ldb (byte 32 32) total-length))
+	;; Flush last block
+	(update-md5-block regs block)
+	;; Done, remember digest for later calls
 	(setf (md5-state-finalized-p state)
 	      (md5regs-digest regs)))))
 
@@ -559,9 +564,123 @@ element-type has to be either (unsigned-byte 8) or character."
 according to the test suite in Appendix A.5 of RFC 1321")
 
 #+md5-testing
-(defun test-rfc1321 ()
+(defconstant +other-testsuite+
+  '(;; From padding bug report by Edi Weitz
+    ("1631901HERR BUCHHEISTERCITROEN NORD1043360796beckenbauer" .
+     "d734945e5930bb28859ccd13c830358b")
+    ;; Test padding for strings from 0 to 69*8 bits in size.
+    ("" . "d41d8cd98f00b204e9800998ecf8427e")
+    ("a" . "0cc175b9c0f1b6a831c399e269772661")
+    ("aa" . "4124bc0a9335c27f086f24ba207a4912")
+    ("aaa" . "47bce5c74f589f4867dbd57e9ca9f808")
+    ("aaaa" . "74b87337454200d4d33f80c4663dc5e5")
+    ("aaaaa" . "594f803b380a41396ed63dca39503542")
+    ("aaaaaa" . "0b4e7a0e5fe84ad35fb5f95b9ceeac79")
+    ("aaaaaaa" . "5d793fc5b00a2348c3fb9ab59e5ca98a")
+    ("aaaaaaaa" . "3dbe00a167653a1aaee01d93e77e730e")
+    ("aaaaaaaaa" . "552e6a97297c53e592208cf97fbb3b60")
+    ("aaaaaaaaaa" . "e09c80c42fda55f9d992e59ca6b3307d")
+    ("aaaaaaaaaaa" . "d57f21e6a273781dbf8b7657940f3b03")
+    ("aaaaaaaaaaaa" . "45e4812014d83dde5666ebdf5a8ed1ed")
+    ("aaaaaaaaaaaaa" . "c162de19c4c3731ca3428769d0cd593d")
+    ("aaaaaaaaaaaaaa" . "451599a5f9afa91a0f2097040a796f3d")
+    ("aaaaaaaaaaaaaaa" . "12f9cf6998d52dbe773b06f848bb3608")
+    ("aaaaaaaaaaaaaaaa" . "23ca472302f49b3ea5592b146a312da0")
+    ("aaaaaaaaaaaaaaaaa" . "88e42e96cc71151b6e1938a1699b0a27")
+    ("aaaaaaaaaaaaaaaaaa" . "2c60c24e7087e18e45055a33f9a5be91")
+    ("aaaaaaaaaaaaaaaaaaa" . "639d76897485360b3147e66e0a8a3d6c")
+    ("aaaaaaaaaaaaaaaaaaaa" . "22d42eb002cefa81e9ad604ea57bc01d")
+    ("aaaaaaaaaaaaaaaaaaaaa" . "bd049f221af82804c5a2826809337c9b")
+    ("aaaaaaaaaaaaaaaaaaaaaa" . "ff49cfac3968dbce26ebe7d4823e58bd")
+    ("aaaaaaaaaaaaaaaaaaaaaaa" . "d95dbfee231e34cccb8c04444412ed7d")
+    ("aaaaaaaaaaaaaaaaaaaaaaaa" . "40edae4bad0e5bf6d6c2dc5615a86afb")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaa" . "a5a8bfa3962f49330227955e24a2e67c")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaa" . "ae791f19bdf77357ff10bb6b0e97e121")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaa" . "aaab9c59a88bf0bdfcb170546c5459d6")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "b0f0545856af1a340acdedce23c54b97")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "f7ce3d7d44f3342107d884bfa90c966a")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "59e794d45697b360e18ba972bada0123")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "3b0845db57c200be6052466f87b2198a")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "5eca9bd3eb07c006cd43ae48dfde7fd3")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "b4f13cb081e412f44e99742cb128a1a5")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" . "4c660346451b8cf91ef50f4634458d41")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "11db24dc3f6c2145701db08625dd6d76")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "80dad3aad8584778352c68ab06250327")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "1227fe415e79db47285cb2689c93963f")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "8e084f489f1bdf08c39f98ff6447ce6d")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "08b2f2b0864bac1ba1585043362cbec9")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "4697843037d962f62a5a429e611e0f5f")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "10c4da18575c092b486f8ab96c01c02f")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "af205d729450b663f48b11d839a1c8df")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "0d3f91798fac6ee279ec2485b25f1124")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "4c3c7c067634daec9716a80ea886d123")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "d1e358e6e3b707282cdd06e919f7e08c")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "8c6ded4f0af86e0a7e301f8a716c4363")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "4c2d8bcb02d982d7cb77f649c0a2dea8")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "bdb662f765cd310f2a547cab1cfecef6")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "08ff5f7301d30200ab89169f6afdb7af")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "6eb6a030bcce166534b95bc2ab45d9cf")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "1bb77918e5695c944be02c16ae29b25e")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "b6fe77c19f0f0f4946c761d62585bfea")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "e9e7e260dce84ffa6e0e7eb5fd9d37fc")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "eced9e0b81ef2bba605cbc5e2e76a1d0")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "ef1772b6dff9a122358552954ad0df65")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "3b0c8ac703f828b04c6c197006d17218")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "652b906d60af96844ebd21b674f35e93")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "dc2f2f2462a0d72358b2f99389458606")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "762fc2665994b217c52c3c2eb7d9f406")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "cc7ed669cf88f201c3297c6a91e1d18d")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "cced11f7bbbffea2f718903216643648")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "24612f0ce2c9d2cf2b022ef1e027a54f")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "b06521f39153d618550606be297466d5")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "014842d480b571495a4a0363793f7367")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "c743a45e0d2e6a95cb859adae0248435")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "def5d97e01e1219fb2fc8da6c4d6ba2f")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "92cb737f8687ccb93022fdb411a77cca")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "a0d1395c7fb36247bfe2d49376d9d133")
+    ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" .
+     "ab75504250558b788f99d1ebd219abf2"))
+  "AList of test input strings and stringified message-digests
+according to my additional test suite")
+
+#+md5-testing
+(defun test-with-testsuite (testsuite)
   (loop for count from 1
-	for (source . md5-string) in +rfc1321-testsuite+
+	for (source . md5-string) in testsuite
 	for md5-digest = (md5sum-sequence source)
 	for md5-result-string = (format nil "~(~{~2,'0X~}~)"
 					(map 'list #'identity md5-digest))
@@ -581,6 +700,14 @@ according to the test suite in Appendix A.5 of RFC 1321")
 		failed (1- count))
 	(return (zerop failed))))
 
+#+md5-testing
+(defun test-rfc1321 ()
+  (test-with-testsuite +rfc1321-testsuite+))
+
+#+md5-testing
+(defun test-other ()
+  (test-with-testsuite +other-testsuite+))
+
 #+cmu
 (eval-when (:compile-toplevel :execute)
   (setq *features* *old-features*))