mirror of
https://github.com/pmai/md5.git
synced 2025-12-21 22:44:29 +01:00
Integrated Lispworks-specific optimizations, refactored types a bit.
This is based on the LW4.4 port of MD5 by Dmitriy Ivanov, with some modernizations and fixes/updates for newer LW.
This commit is contained in:
202
md5.lisp
202
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*))
|
||||
|
||||
Reference in New Issue
Block a user