diff --git a/md5.lisp b/md5.lisp index 35a6470..b11ce45 100644 --- a/md5.lisp +++ b/md5.lisp @@ -66,16 +66,42 @@ (defparameter *old-features* *features*) (pushnew sb-c:*backend-byte-order* *features*)) +#+(and :lispworks (or (not :lispworks4) :lispworks4.4)) +(eval-when (:compile-toplevel :execute) + (defparameter *old-features* *features*) + (pushnew :lw-int32 *features*)) + ;;; Section 2: Basic Datatypes (deftype ub32 () "Corresponds to the 32bit quantity word of the MD5 Spec" - `(unsigned-byte 32)) + #+lw-int32 'sys:int32 + #-lw-int32 '(unsigned-byte 32)) -(defmacro assemble-ub32 (a b c d) - "Assemble an ub32 value from the given (unsigned-byte 8) values, +(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))) + #+lw-int32 + `(sys:int32-logior (sys:int32<< ,d 24) + (sys:int32-logior (sys:int32<< ,c 16) + (sys:int32-logior (sys:int32<< ,b 8) ,a))) + #-lw-int32 + `(the ub32 (logior (ash ,d 24) (ash ,c 16) (ash ,b 8) ,a)))) + +(deftype ub32-vector (length) + #+lw-int32 `(sys:simple-int32-vector ,length) + #-lw-int32 `(simple-array (unsigned-byte 32) (,length))) + +(defmacro make-ub32-vector (length &rest args) + #+lw-int32 `(sys:make-simple-int32-vector ,length ,@args) + #-lw-int32 `(make-array ,length :element-type 'ub32 ,@args)) + +(defmacro ub32-aref (vector index) + #+lw-int32 + `(sys:int32-aref ,vector ,index) + #-lw-int32 + `(aref ,vector ,index)) ;;; Section 3.4: Auxilliary functions @@ -84,43 +110,53 @@ where a is the intended low-order byte and d the high-order byte." (defun f (x y z) (declare (type ub32 x y z) - (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0))) #+cmu (kernel:32bit-logical-or (kernel:32bit-logical-and x y) (kernel:32bit-logical-andc1 x z)) - #-cmu + #+lw-int32 + (sys:int32-logior (sys:int32-logand x y) (sys:int32-logandc1 x z)) + #-(or :cmu :lw-int32) (logior (logand x y) (logandc1 x z))) (defun g (x y z) (declare (type ub32 x y z) - (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0))) #+cmu (kernel:32bit-logical-or (kernel:32bit-logical-and x z) (kernel:32bit-logical-andc2 y z)) - #-cmu + #+lw-int32 + (sys:int32-logior (sys:int32-logand x z) (sys:int32-logandc2 y z)) + #-(or :cmu :lw-int32) (logior (logand x z) (logandc2 y z))) (defun h (x y z) (declare (type ub32 x y z) - (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0))) #+cmu (kernel:32bit-logical-xor x (kernel:32bit-logical-xor y z)) - #-cmu + #+lw-int32 + (sys:int32-logxor x (sys:int32-logxor y z)) + #-(or :cmu :lw-int32) (logxor x y z)) (defun i (x y z) (declare (type ub32 x y z) - (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0))) #+cmu (kernel:32bit-logical-xor y (kernel:32bit-logical-orc2 x z)) - #-cmu + #+lw-int32 + (sys:int32-logxor y (sys:int32-logorc2 x z)) + #-(or :cmu :lw-int32) (ldb (byte 32 0) (logxor y (logorc2 x z)))) (declaim (inline mod32+) (ftype (function (ub32 ub32) ub32) mod32+)) (defun mod32+ (a b) - (declare (type ub32 a b) (optimize (speed 3) (safety 0) (space 0) (debug 0))) - (ldb (byte 32 0) (+ a b))) + (declare (type ub32 a b) + (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0))) + #+lw-int32 (sys:int32+ a b) + #-lw-int32 (ldb (byte 32 0) (+ a b))) #+cmu (define-compiler-macro mod32+ (a b) @@ -132,18 +168,31 @@ where a is the intended low-order byte and d the high-order byte." (define-compiler-macro mod32+ (a b) `(ldb (byte 32 0) (+ ,a ,b))) +#+lw-int32 +(declaim (inline int32>>logical) + (ftype (function (sys:int32 (unsigned-byte 5)) sys:int32) int32>>logical)) +#+lw-int32 +(defun int32>>logical (a s) + (declare (type ub32 a) (type (unsigned-byte 5) s) + (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0))) + (if (sys:int32-minusp a) + (sys:int32-logandc2 (sys:int32>> a s) (sys:int32<< -1 (- 32 s))) + (sys:int32>> a s))) + (declaim (inline rol32) (ftype (function (ub32 (unsigned-byte 5)) ub32) rol32)) (defun rol32 (a s) (declare (type ub32 a) (type (unsigned-byte 5) s) - (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0))) #+cmu (kernel:32bit-logical-or #+little-endian (kernel:shift-towards-end a s) #+big-endian (kernel:shift-towards-start a s) (ash a (- s 32))) #+sbcl (sb-rotate-byte:rotate-byte s (byte 32 0) a) - #-(or cmu sbcl) + #+lw-int32 + (sys:int32-logior (sys:int32<< a s) (int32>>logical a (- 32 s))) + #-(or cmu sbcl lw-int32) (logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32)))) ;;; Section 3.4: Table T @@ -159,35 +208,54 @@ where a is the intended low-order byte and d the high-order byte." ;;; Section 3.4: Helper Macro for single round definitions +#-lw-int32 (defmacro with-md5-round ((op block) &rest clauses) (loop for (a b c d k s i) in clauses collect `(setq ,a (mod32+ ,b (rol32 (mod32+ (mod32+ ,a (,op ,b ,c ,d)) - (mod32+ (aref ,block ,k) + (mod32+ (ub32-aref ,block ,k) ,(aref *t* (1- i)))) ,s))) into result finally (return `(progn ,@result)))) +#+lw-int32 +(defmacro with-md5-round ((op block) &rest clauses) + (loop for (a b c d k s i) in clauses + collect + `(setq ,a (mod32+ ,b (rol32 (mod32+ (mod32+ ,a (,op ,b ,c ,d)) + (mod32+ (ub32-aref ,block ,k) + (sys:integer-to-int32 + ,(let ((t-val (aref *t* (1- i)))) + (dpb (ldb (byte 32 0) t-val) + (byte 32 0) + (if (logbitp 31 t-val) + -1 + 0)))))) + ,s))) + into result + finally + (return `(progn ,@result)))) + ;;; Section 3.3: (Initial) MD5 Working Set (deftype md5-regs () "The working state of the MD5 algorithm, which contains the 4 32-bit registers A, B, C and D." - `(simple-array (unsigned-byte 32) (4))) + `(ub32-vector 4)) (defmacro md5-regs-a (regs) - `(aref ,regs 0)) + `(ub32-aref ,regs 0)) (defmacro md5-regs-b (regs) - `(aref ,regs 1)) + `(ub32-aref ,regs 1)) (defmacro md5-regs-c (regs) - `(aref ,regs 2)) + `(ub32-aref ,regs 2)) (defmacro md5-regs-d (regs) - `(aref ,regs 3)) + `(ub32-aref ,regs 3)) (defconstant +md5-magic-a+ (assemble-ub32 #x01 #x23 #x45 #x67) "Initial value of Register A of the MD5 working state.") @@ -201,8 +269,8 @@ registers A, B, C and D." (declaim (inline initial-md5-regs)) (defun initial-md5-regs () "Create the initial working state of an MD5 run." - (declare (optimize (speed 3) (safety 0) (space 0) (debug 0))) - (let ((regs (make-array 4 :element-type '(unsigned-byte 32)))) + (declare (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 0))) + (let ((regs (make-ub32-vector 4))) (declare (type md5-regs regs)) (setf (md5-regs-a regs) +md5-magic-a+ (md5-regs-b regs) +md5-magic-b+ @@ -212,13 +280,17 @@ registers A, B, C and D." ;;; Section 3.4: Operation on 16-Word Blocks +(deftype md5-block () + "The basic 16x32-bit word blocks that MD5 operates on." + `(ub32-vector 16)) + (defun update-md5-block (regs block) "This is the core part of the MD5 algorithm. It takes a complete 16 word block of input, and updates the working state in A, B, C, and D accordingly." (declare (type md5-regs regs) - (type (simple-array ub32 (16)) block) - (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (type md5-block block) + (optimize (speed 3) (safety 0) (space 0) (debug 0) #+lw-int32 (float 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)) @@ -256,28 +328,14 @@ accordingly." ;;; 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 starting from offset into the given 16 word MD5 block." (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) - (type (simple-array ub32 (16)) block) + (type md5-block block) (type (simple-array (unsigned-byte 8) (*)) buffer) - (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (optimize (speed 3) (safety 0) (space 0) (debug 0) + #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0))) #+(and :cmu :little-endian) (kernel:bit-bash-copy buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) @@ -290,7 +348,7 @@ starting from offset into the given 16 word MD5 block." for j of-type (integer 0 #.most-positive-fixnum) from offset to (+ offset 63) by 4 do - (setf (aref block i) + (setf (ub32-aref block i) (assemble-ub32 (aref buffer j) (aref buffer (+ j 1)) (aref buffer (+ j 2)) @@ -300,9 +358,10 @@ starting from offset into the given 16 word MD5 block." "Convert a complete 64 character input string segment starting from offset into the given 16 word MD5 block." (declare (type (integer 0 #.(- most-positive-fixnum 64)) offset) - (type (simple-array ub32 (16)) block) + (type md5-block block) (type simple-string buffer) - (optimize (speed 3) (safety 0) (space 0) (debug 0))) + (optimize (speed 3) (safety 0) (space 0) (debug 0) + #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0))) #+(and :cmu :little-endian) (kernel:bit-bash-copy buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) @@ -315,26 +374,44 @@ offset into the given 16 word MD5 block." for j of-type (integer 0 #.most-positive-fixnum) from offset to (+ offset 63) by 4 do - (setf (aref block i) + (setf (ub32-aref block i) (assemble-ub32 (char-code (schar buffer j)) (char-code (schar buffer (+ j 1))) (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 md5-block block) + (type (simple-array * (*)) buffer) + (optimize (speed 3) (safety 0) (space 0) (debug 0) + #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 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)) (defun md5regs-digest (regs) "Create the final 16 byte message-digest from the MD5 working state in regs. Returns a (simple-array (unsigned-byte 8) (16))." - (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) + (declare (optimize (speed 3) (safety 0) (space 0) (debug 0) + #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0)) (type md5-regs regs)) (let ((result (make-array 16 :element-type '(unsigned-byte 8)))) (declare (type (simple-array (unsigned-byte 8) (16)) result)) (macrolet ((frob (reg offset) (let ((var (gensym))) - `(let ((,var ,reg)) - (declare (type ub32 ,var)) + `(let ((,var #+lw-int32 (sys:int32-to-integer ,reg) + #-lw-int32 ,reg)) + (declare (type (unsigned-byte 32) ,var)) (setf (aref result ,offset) (ldb (byte 8 0) ,var) (aref result ,(+ offset 1)) (ldb (byte 8 8) ,var) @@ -355,8 +432,7 @@ in regs. Returns a (simple-array (unsigned-byte 8) (16))." (amount 0 :type #-md5-small-length (integer 0 *) #+md5-small-length (unsigned-byte 29)) - (block (make-array 16 :element-type '(unsigned-byte 32)) :read-only t - :type (simple-array (unsigned-byte 32) (16))) + (block (make-ub32-vector 16) :read-only t :type md5-block) (buffer (make-array 64 :element-type '(unsigned-byte 8)) :read-only t :type (simple-array (unsigned-byte 8) (64))) (buffer-index 0 :type (integer 0 63)) @@ -367,7 +443,8 @@ in regs. Returns a (simple-array (unsigned-byte 8) (16))." "Copy a partial segment from input vector from starting at from-offset and copying count elements into the 64 byte buffer starting at buffer-offset." - (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)) + (declare (optimize (speed 3) (safety 0) (space 0) (debug 0) + #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0)) (type (unsigned-byte 29) from-offset) (type (integer 0 63) count buffer-offset) (type (simple-array * (*)) from) @@ -405,7 +482,8 @@ bounded by start and end, which must be numeric bounding-indices." (declare (type md5-state state) (type (simple-array * (*)) sequence) (type fixnum start end) - (optimize (speed 3) (safety 1) (space 0) (debug 1))) + (optimize (speed 3) (safety 1) (space 0) (debug 1) + #+lw-int32 (float 0) #+lw-int32 (hcl:fixnum-safety 0))) (locally (declare (optimize (safety 0) (debug 0))) (let ((regs (md5-state-regs state)) @@ -415,7 +493,7 @@ bounded by start and end, which must be numeric bounding-indices." (length (- end start))) (declare (type md5-regs regs) (type fixnum length) (type (integer 0 63) buffer-index) - (type (simple-array (unsigned-byte 32) (16)) block) + (type md5-block block) (type (simple-array (unsigned-byte 8) (64)) buffer)) ;; Handle old rest (unless (zerop buffer-index) @@ -478,7 +556,7 @@ The resulting MD5 message-digest is returned as an array of sixteen (unsigned-byte 8) values. Calling `update-md5-state' after a call to `finalize-md5-state' results in unspecified behaviour." (declare (type md5-state state) - (optimize (speed 3) (safety 1) (space 0) (debug 1))) + (optimize (speed 3) (safety 1) (space 0) (debug 1) #+lw-int32 (float 0))) (locally (declare (optimize (safety 0) (debug 0))) (or (md5-state-finalized-p state) @@ -489,7 +567,7 @@ The resulting MD5 message-digest is returned as an array of sixteen (total-length (* 8 (md5-state-amount state)))) (declare (type md5-regs regs) (type (integer 0 63) buffer-index) - (type (simple-array ub32 (16)) block) + (type md5-block block) (type (simple-array (unsigned-byte 8) (*)) buffer)) ;; Add mandatory bit 1 padding (setf (aref buffer buffer-index) #x80) @@ -503,11 +581,11 @@ The resulting MD5 message-digest is returned as an array of sixteen (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))) + do (setf (ub32-aref block index) #x00000000))) ;; Add 64bit message bit length - (setf (aref block 14) (ldb (byte 32 0) total-length)) + (setf (ub32-aref block 14) (ldb (byte 32 0) total-length)) #-md5-small-length - (setf (aref block 15) (ldb (byte 32 32) total-length)) + (setf (ub32-aref block 15) (ldb (byte 32 32) total-length)) ;; Flush last block (update-md5-block regs block) ;; Done, remember digest for later calls @@ -798,3 +876,7 @@ according to my additional test suite") #+sbcl (eval-when (:compile-toplevel :execute) (setq *features* *old-features*)) + +#+(and :lispworks (or (not :lispworks4) :lispworks4.4)) +(eval-when (:compile-toplevel :execute) + (setq *features* *old-features*))