X-Git-Url: http://git.kpe.io/?p=md5.git;a=blobdiff_plain;f=md5.lisp;h=46ff79c04d22dd9aa1ffbcc3da7b7bb1362c303d;hp=7349948d7b8389abe955293cd8569f4b32b0ef1e;hb=9f8ae6743f261a51007a1048080f2d40282a4217;hpb=4af6b44d218425b37b3314aa6de84653a54f3736 diff --git a/md5.lisp b/md5.lisp index 7349948..46ff79c 100644 --- a/md5.lisp +++ b/md5.lisp @@ -5,7 +5,7 @@ ;;;; cmucl-help mailing-list hosted at cons.org, in November 2001 and ;;;; has been placed into the public domain. ;;;; -;;;; $Id: md5.lisp,v 1.5 2003/05/06 04:59:21 kevin Exp $ +;;;; $Id$ ;;;; ;;;; While the implementation should work on all conforming Common ;;;; Lisp implementations, it has only been optimized for CMU CL, @@ -63,15 +63,22 @@ ;;; Section 2: Basic Datatypes +#-lispworks (eval-when (:compile-toplevel :load-toplevel :execute) (deftype ub32 () "Corresponds to the 32bit quantity word of the MD5 Spec" `(unsigned-byte 32))) -(defmacro assemble-ub32 (a b c d) - "Assemble an ub32 value from the given (unsigned-byte 8) values, +#+lispworks +(deftype ub32 () + "Corresponds to the 32bit quantity word of the MD5 Spec" + `(unsigned-byte 32)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defmacro assemble-ub32 (a b c d) + "Assemble an ub32 value from the given (unsigned-byte 8) values, where a is the intended low-order byte and d the high-order byte." - `(the ub32 (logior (ash ,d 24) (ash ,c 16) (ash ,b 8) ,a))) + `(the ub32 (logior (ash ,d 24) (ash ,c 16) (ash ,b 8) ,a)))) ;;; Section 3.4: Auxilliary functions @@ -110,7 +117,7 @@ where a is the intended low-order byte and d the high-order byte." #+cmu (kernel:32bit-logical-xor y (kernel:32bit-logical-orc2 x z)) #-cmu - (logxor y (logorc2 x z))) + (ldb (byte 32 0) (logxor y (logorc2 x z)))) (declaim (inline mod32+) (ftype (function (ub32 ub32) ub32) mod32+)) @@ -207,9 +214,9 @@ accordingly." (declare (type md5-regs regs) (type (simple-array ub32 (16)) block) (optimize (speed 3) (safety 0) (space 0) (debug 0))) - (let ((a (md5-regs-a regs)) (b (md5-regs-b regs)) - (c (md5-regs-c regs)) (d (md5-regs-d regs))) - (declare (type ub32 a b c d)) + (let ((A (md5-regs-a regs)) (B (md5-regs-b regs)) + (C (md5-regs-c regs)) (D (md5-regs-d regs))) + (declare (type ub32 A B C D)) ;; Round 1 (with-md5-round (f block) (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) @@ -235,29 +242,15 @@ accordingly." (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) (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)) ;; Update and return - (setf (md5-regs-a regs) (mod32+ (md5-regs-a regs) a) - (md5-regs-b regs) (mod32+ (md5-regs-b regs) b) - (md5-regs-c regs) (mod32+ (md5-regs-c regs) c) - (md5-regs-d regs) (mod32+ (md5-regs-d regs) d)) + (setf (md5-regs-a regs) (mod32+ (md5-regs-a regs) A) + (md5-regs-b regs) (mod32+ (md5-regs-b regs) B) + (md5-regs-c regs) (mod32+ (md5-regs-c regs) C) + (md5-regs-d regs) (mod32+ (md5-regs-d regs) D)) regs)) ;;; Section 3.4: Converting 8bit-vectors into 16-Word Blocks (declaim (inline fill-block fill-block-ub8 fill-block-char)) -(defun fill-block (block buffer offset) - "Convert a complete 64 byte input vector segment into the given 16 -word MD5 block. This currently works on (unsigned-byte 8) and -character simple-arrays, via the functions `fill-block-ub8' and -`fill-block-char' respectively." - (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) - (type (simple-array ub32 (16)) block) - (type (simple-array * (*)) buffer) - (optimize (speed 3) (safety 0) (space 0) (debug 0))) - (etypecase buffer - ((simple-array (unsigned-byte 8) (*)) - (fill-block-ub8 block buffer offset)) - (simple-string - (fill-block-char block buffer offset)))) (defun fill-block-ub8 (block buffer offset) "Convert a complete 64 (unsigned-byte 8) input vector segment @@ -305,6 +298,21 @@ offset into the given 16 word MD5 block." (char-code (schar buffer (+ j 2))) (char-code (schar buffer (+ j 3))))))) +(defun fill-block (block buffer offset) + "Convert a complete 64 byte input vector segment into the given 16 +word MD5 block. This currently works on (unsigned-byte 8) and +character simple-arrays, via the functions `fill-block-ub8' and +`fill-block-char' respectively." + (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) + (type (simple-array ub32 (16)) block) + (type (simple-array * (*)) buffer) + (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (etypecase buffer + ((simple-array (unsigned-byte 8) (*)) + (fill-block-ub8 block buffer offset)) + (simple-string + (fill-block-char block buffer offset)))) + ;;; Section 3.5: Message Digest Output (declaim (inline md5regs-digest)) @@ -392,24 +400,34 @@ bounded by start and end, which must be numeric bounding-indices." (ext:optimize-interface (safety 1) (debug 1))) (let ((regs (md5-state-regs state)) (block (md5-state-block state)) - (buffer (md5-state-buffer state)) - (buffer-index (md5-state-buffer-index state)) - (length (- end start))) - (declare (type md5-regs regs) (type fixnum length) - (type (integer 0 63) buffer-index) + (buffer (md5-state-buffer state))) + (declare (type md5-regs regs) (type (simple-array (unsigned-byte 32) (16)) block) (type (simple-array (unsigned-byte 8) (64)) buffer)) ;; Handle old rest - (unless (zerop buffer-index) - (let ((amount (min (- 64 buffer-index) length))) - (declare (type (integer 0 63) amount)) - (copy-to-buffer sequence start amount buffer buffer-index) - (setq start (the fixnum (+ start amount))) - (when (>= start end) - (setf (md5-state-buffer-index state) (+ buffer-index amount)) - (return-from update-md5-state state))) - (fill-block-ub8 block buffer 0) - (update-md5-block regs block)) + (unless (zerop (md5-state-buffer-index state)) + (let* ((buffer-index (md5-state-buffer-index state)) + (remainder (- 64 buffer-index)) + (length (- end start)) + (amount (min remainder length))) + (declare (type (integer 0 63) buffer-index remainder amount) + (type fixnum length)) + (copy-to-buffer sequence start amount buffer buffer-index) + (setf (md5-state-amount state) + #-md5-small-length (+ (md5-state-amount state) amount) + #+md5-small-length (the (unsigned-byte 29) + (+ (md5-state-amount state) amount))) + (setq start (the fixnum (+ start amount))) + (if (< length remainder) + (setf (md5-state-buffer-index state) + (the (integer 0 63) (+ buffer-index amount))) + (progn + (fill-block-ub8 block buffer 0) + (update-md5-block regs block) + (setf (md5-state-buffer-index state) 0))))) + ;; Leave when nothing to do + (when (>= start end) + (return-from update-md5-state state)) ;; Handle main-part and new-rest (etypecase sequence ((simple-array (unsigned-byte 8) (*)) @@ -439,9 +457,11 @@ bounded by start and end, which must be numeric bounding-indices." (copy-to-buffer sequence offset amount buffer 0)) (setf (md5-state-buffer-index state) amount)))))) (setf (md5-state-amount state) - #-md5-small-length (+ (md5-state-amount state) length) + #-md5-small-length (+ (md5-state-amount state) + (the fixnum (- end start))) #+md5-small-length (the (unsigned-byte 29) - (+ (md5-state-amount state) length))) + (+ (md5-state-amount state) + (the fixnum (- end start))))) state)) (defun finalize-md5-state (state)