OSCL/md5
2
0
Fork 0
mirror of https://github.com/pmai/md5.git synced 2025-12-21 22:44:29 +01:00
Code Issues Packages Projects Releases Wiki Activity

Added SBCL-specific changes from sb-md5, including fillpointer-fix for cmu.

Browse Source
This commit is contained in:
Pierre R. Mai
2012-10-18 02:47:30 +02:00
parent e80c820384
commit 81e33f2983
1 changed files with 180 additions and 141 deletions
Download Patch File Download Diff File Expand all files Collapse all files

321
md5.lisp
View File

@ -61,6 +61,11 @@
(defparameter *old-features* *features*) (defparameter *old-features* *features*)
(pushnew (c:backend-byte-order c:*target-backend*) *features*)) (pushnew (c:backend-byte-order c:*target-backend*) *features*))
#+sbcl
(eval-when (:compile-toplevel :execute)
(defparameter *old-features* *features*)
(pushnew sb-c:*backend-byte-order* *features*))
;;; Section 2: Basic Datatypes ;;; Section 2: Basic Datatypes
(deftype ub32 () (deftype ub32 ()
@ -121,6 +126,12 @@ where a is the intended low-order byte and d the high-order byte."
(define-compiler-macro mod32+ (a b) (define-compiler-macro mod32+ (a b)
`(ext:truly-the ub32 (+ ,a ,b))) `(ext:truly-the ub32 (+ ,a ,b)))
;;; Dunno why we need this, but without it MOD32+ wasn't being
;;; inlined. Oh well. -- CSR, 2003-09-14
#+sbcl
(define-compiler-macro mod32+ (a b)
`(ldb (byte 32 0) (+ ,a ,b)))
(declaim (inline rol32) (declaim (inline rol32)
(ftype (function (ub32 (unsigned-byte 5)) ub32) rol32)) (ftype (function (ub32 (unsigned-byte 5)) ub32) rol32))
(defun rol32 (a s) (defun rol32 (a s)
@ -128,9 +139,11 @@ where a is the intended low-order byte and d the high-order byte."
(optimize (speed 3) (safety 0) (space 0) (debug 0))) (optimize (speed 3) (safety 0) (space 0) (debug 0)))
#+cmu #+cmu
(kernel:32bit-logical-or #+little-endian (kernel:shift-towards-end a s) (kernel:32bit-logical-or #+little-endian (kernel:shift-towards-end a s)
#+big-endian (kernel:shift-towards-start a s) #+big-endian (kernel:shift-towards-start a s)
(ash a (- s 32))) (ash a (- s 32)))
#-cmu #+sbcl
(sb-rotate-byte:rotate-byte s (byte 32 0) a)
#-(or cmu sbcl)
(logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32)))) (logior (ldb (byte 32 0) (ash a s)) (ash a (- s 32))))
;;; Section 3.4: Table T ;;; Section 3.4: Table T
@ -270,7 +283,9 @@ starting from offset into the given 16 word MD5 block."
buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits))
block (* vm:vector-data-offset vm:word-bits) block (* vm:vector-data-offset vm:word-bits)
(* 64 vm:byte-bits)) (* 64 vm:byte-bits))
#-(and :cmu :little-endian) #+(and :sbcl :little-endian)
(sb-kernel:ub8-bash-copy buffer offset block 0 64)
#-(or (and :sbcl :little-endian) (and :cmu :little-endian))
(loop for i of-type (integer 0 16) from 0 (loop for i of-type (integer 0 16) from 0
for j of-type (integer 0 #.most-positive-fixnum) for j of-type (integer 0 #.most-positive-fixnum)
from offset to (+ offset 63) by 4 from offset to (+ offset 63) by 4
@ -293,7 +308,9 @@ offset into the given 16 word MD5 block."
buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits)) buffer (+ (* vm:vector-data-offset vm:word-bits) (* offset vm:byte-bits))
block (* vm:vector-data-offset vm:word-bits) block (* vm:vector-data-offset vm:word-bits)
(* 64 vm:byte-bits)) (* 64 vm:byte-bits))
#-(and :cmu :little-endian) #+(and :sbcl :little-endian)
(sb-kernel:ub8-bash-copy buffer offset block 0 64)
#-(or (and :sbcl :little-endian) (and :cmu :little-endian))
(loop for i of-type (integer 0 16) from 0 (loop for i of-type (integer 0 16) from 0
for j of-type (integer 0 #.most-positive-fixnum) for j of-type (integer 0 #.most-positive-fixnum)
from offset to (+ offset 63) by 4 from offset to (+ offset 63) by 4
@ -361,7 +378,9 @@ starting at buffer-offset."
buffer (+ (* vm:vector-data-offset vm:word-bits) buffer (+ (* vm:vector-data-offset vm:word-bits)
(* buffer-offset vm:byte-bits)) (* buffer-offset vm:byte-bits))
(* count vm:byte-bits)) (* count vm:byte-bits))
#-cmu #+sbcl
(sb-kernel:ub8-bash-copy from from-offset buffer buffer-offset count)
#-(or cmu sbcl)
(etypecase from (etypecase from
(simple-string (simple-string
(loop for buffer-index of-type (integer 0 64) from buffer-offset (loop for buffer-index of-type (integer 0 64) from buffer-offset
@ -386,69 +405,69 @@ bounded by start and end, which must be numeric bounding-indices."
(declare (type md5-state state) (declare (type md5-state state)
(type (simple-array * (*)) sequence) (type (simple-array * (*)) sequence)
(type fixnum start end) (type fixnum start end)
(optimize (speed 3) #+cmu (safety 0) (space 0) (debug 0)) (optimize (speed 3) (safety 1) (space 0) (debug 1)))
#+cmu (locally
(ext:optimize-interface (safety 1) (debug 1))) (declare (optimize (safety 0) (debug 0)))
(let ((regs (md5-state-regs state)) (let ((regs (md5-state-regs state))
(block (md5-state-block state)) (block (md5-state-block state))
(buffer (md5-state-buffer state)) (buffer (md5-state-buffer state))
(buffer-index (md5-state-buffer-index state)) (buffer-index (md5-state-buffer-index state))
(length (- end start))) (length (- end start)))
(declare (type md5-regs regs) (type fixnum length) (declare (type md5-regs regs) (type fixnum length)
(type (integer 0 63) buffer-index) (type (integer 0 63) buffer-index)
(type (simple-array (unsigned-byte 32) (16)) block) (type (simple-array (unsigned-byte 32) (16)) block)
(type (simple-array (unsigned-byte 8) (64)) buffer)) (type (simple-array (unsigned-byte 8) (64)) buffer))
;; Handle old rest ;; Handle old rest
(unless (zerop buffer-index) (unless (zerop buffer-index)
(let ((amount (min (- 64 buffer-index) length))) (let ((amount (min (- 64 buffer-index) length)))
(declare (type (integer 0 63) amount)) (declare (type (integer 0 63) amount))
(copy-to-buffer sequence start amount buffer buffer-index) (copy-to-buffer sequence start amount buffer buffer-index)
(setq start (the fixnum (+ start amount))) (setq start (the fixnum (+ start amount)))
(let ((new-index (+ buffer-index amount))) (let ((new-index (+ buffer-index amount)))
(when (= new-index 64) (when (= new-index 64)
(fill-block-ub8 block buffer 0) (fill-block-ub8 block buffer 0)
(update-md5-block regs block) (update-md5-block regs block)
(setq new-index 0)) (setq new-index 0))
(when (>= start end) (when (>= start end)
(setf (md5-state-buffer-index state) new-index (setf (md5-state-buffer-index state) new-index
(md5-state-amount state) (md5-state-amount state)
#-md5-small-length (+ (md5-state-amount state) length) #-md5-small-length (+ (md5-state-amount state) length)
#+md5-small-length (the (unsigned-byte 29) #+md5-small-length (the (unsigned-byte 29)
(+ (md5-state-amount state) length))) (+ (md5-state-amount state) length)))
(return-from update-md5-state state))))) (return-from update-md5-state state)))))
;; Handle main-part and new-rest ;; Handle main-part and new-rest
(etypecase sequence (etypecase sequence
((simple-array (unsigned-byte 8) (*)) ((simple-array (unsigned-byte 8) (*))
(locally (locally
(declare (type (simple-array (unsigned-byte 8) (*)) sequence)) (declare (type (simple-array (unsigned-byte 8) (*)) sequence))
(loop for offset of-type (unsigned-byte 29) from start below end by 64 (loop for offset of-type (unsigned-byte 29) from start below end by 64
until (< (- end offset) 64) until (< (- end offset) 64)
do do
(fill-block-ub8 block sequence offset) (fill-block-ub8 block sequence offset)
(update-md5-block regs block) (update-md5-block regs block)
finally finally
(let ((amount (- end offset))) (let ((amount (- end offset)))
(unless (zerop amount) (unless (zerop amount)
(copy-to-buffer sequence offset amount buffer 0)) (copy-to-buffer sequence offset amount buffer 0))
(setf (md5-state-buffer-index state) amount))))) (setf (md5-state-buffer-index state) amount)))))
(simple-string (simple-string
(locally (locally
(declare (type simple-string sequence)) (declare (type simple-string sequence))
(loop for offset of-type (unsigned-byte 29) from start below end by 64 (loop for offset of-type (unsigned-byte 29) from start below end by 64
until (< (- end offset) 64) until (< (- end offset) 64)
do do
(fill-block-char block sequence offset) (fill-block-char block sequence offset)
(update-md5-block regs block) (update-md5-block regs block)
finally finally
(let ((amount (- end offset))) (let ((amount (- end offset)))
(unless (zerop amount) (unless (zerop amount)
(copy-to-buffer sequence offset amount buffer 0)) (copy-to-buffer sequence offset amount buffer 0))
(setf (md5-state-buffer-index state) amount)))))) (setf (md5-state-buffer-index state) amount))))))
(setf (md5-state-amount state) (setf (md5-state-amount state)
#-md5-small-length (+ (md5-state-amount state) length) #-md5-small-length (+ (md5-state-amount state) length)
#+md5-small-length (the (unsigned-byte 29) #+md5-small-length (the (unsigned-byte 29)
(+ (md5-state-amount state) length))) (+ (md5-state-amount state) length)))
state)) state)))
(defun finalize-md5-state (state) (defun finalize-md5-state (state)
"If the given md5-state has not already been finalized, finalize it, "If the given md5-state has not already been finalized, finalize it,
@ -459,41 +478,41 @@ The resulting MD5 message-digest is returned as an array of sixteen
(unsigned-byte 8) values. Calling `update-md5-state' after a call to (unsigned-byte 8) values. Calling `update-md5-state' after a call to
`finalize-md5-state' results in unspecified behaviour." `finalize-md5-state' results in unspecified behaviour."
(declare (type md5-state state) (declare (type md5-state state)
(optimize (speed 3) #+cmu (safety 0) (space 0) (debug 0)) (optimize (speed 3) (safety 1) (space 0) (debug 1)))
#+cmu (locally
(ext:optimize-interface (safety 1) (debug 1))) (declare (optimize (safety 0) (debug 0)))
(or (md5-state-finalized-p state) (or (md5-state-finalized-p state)
(let ((regs (md5-state-regs state)) (let ((regs (md5-state-regs state))
(block (md5-state-block state)) (block (md5-state-block state))
(buffer (md5-state-buffer state)) (buffer (md5-state-buffer state))
(buffer-index (md5-state-buffer-index state)) (buffer-index (md5-state-buffer-index state))
(total-length (* 8 (md5-state-amount state)))) (total-length (* 8 (md5-state-amount state))))
(declare (type md5-regs regs) (declare (type md5-regs regs)
(type (integer 0 63) buffer-index) (type (integer 0 63) buffer-index)
(type (simple-array ub32 (16)) block) (type (simple-array ub32 (16)) block)
(type (simple-array (unsigned-byte 8) (*)) buffer)) (type (simple-array (unsigned-byte 8) (*)) buffer))
;; Add mandatory bit 1 padding ;; Add mandatory bit 1 padding
(setf (aref buffer buffer-index) #x80) (setf (aref buffer buffer-index) #x80)
;; Fill with 0 bit padding ;; Fill with 0 bit padding
(loop for index of-type (integer 0 64) (loop for index of-type (integer 0 64)
from (1+ buffer-index) below 64 from (1+ buffer-index) below 64
do (setf (aref buffer index) #x00)) do (setf (aref buffer index) #x00))
(fill-block-ub8 block buffer 0) (fill-block-ub8 block buffer 0)
;; Flush block first if length wouldn't fit ;; Flush block first if length wouldn't fit
(when (>= buffer-index 56) (when (>= buffer-index 56)
(update-md5-block regs block) (update-md5-block regs block)
;; Create new fully 0 padded block ;; Create new fully 0 padded block
(loop for index of-type (integer 0 16) from 0 below 16 (loop for index of-type (integer 0 16) from 0 below 16
do (setf (aref block index) #x00000000))) do (setf (aref block index) #x00000000)))
;; Add 64bit message bit length ;; Add 64bit message bit length
(setf (aref block 14) (ldb (byte 32 0) total-length)) (setf (aref block 14) (ldb (byte 32 0) total-length))
#-md5-small-length #-md5-small-length
(setf (aref block 15) (ldb (byte 32 32) total-length)) (setf (aref block 15) (ldb (byte 32 32) total-length))
;; Flush last block ;; Flush last block
(update-md5-block regs block) (update-md5-block regs block)
;; Done, remember digest for later calls ;; Done, remember digest for later calls
(setf (md5-state-finalized-p state) (setf (md5-state-finalized-p state)
(md5regs-digest regs))))) (md5regs-digest regs))))))
;;; High-Level Drivers ;;; High-Level Drivers
@ -502,18 +521,32 @@ The resulting MD5 message-digest is returned as an array of sixteen
this works for all sequences whose element-type is supported by the this works for all sequences whose element-type is supported by the
underlying MD5 routines, on other implementations it only works for 1d underlying MD5 routines, on other implementations it only works for 1d
simple-arrays with such element types." simple-arrays with such element types."
(declare (optimize (speed 3) (space 0) (debug 0)) (declare (optimize (speed 3) (safety 3) (space 0) (debug 1))
(type vector sequence) (type fixnum start)) (type vector sequence) (type fixnum start))
(let ((state (make-md5-state))) (locally
(declare (type md5-state state)) (declare (optimize (safety 1) (debug 0)))
#+cmu (let ((state (make-md5-state)))
(lisp::with-array-data ((data sequence) (real-start start) (real-end end)) (declare (type md5-state state))
(update-md5-state state data :start real-start :end real-end)) #+cmu
#-cmu (let ((end (or end (length sequence))))
(let ((real-end (or end (length sequence)))) (lisp::with-array-data ((data sequence) (real-start start) (real-end end))
(declare (type fixnum real-end)) (declare (ignore real-end))
(update-md5-state state sequence :start start :end real-end)) (update-md5-state state data :start real-start
(finalize-md5-state state))) :end (+ real-start (- end start)))))
#+sbcl
(let ((end (or end (length sequence))))
(sb-kernel:with-array-data ((data sequence)
(real-start start)
(real-end end)
:check-fill-pointer t)
(declare (ignore real-end))
(update-md5-state state data :start real-start
:end (+ real-start (- end start)))))
#-(or cmu sbcl)
(let ((real-end (or end (length sequence))))
(declare (type fixnum real-end))
(update-md5-state state sequence :start start :end real-end))
(finalize-md5-state state))))
(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant +buffer-size+ (* 128 1024) (defconstant +buffer-size+ (* 128 1024)
@ -525,35 +558,37 @@ operations. This should be a multiple of 64, the MD5 block size."))
(defun md5sum-stream (stream) (defun md5sum-stream (stream)
"Calculate an MD5 message-digest of the contents of stream. Its "Calculate an MD5 message-digest of the contents of stream. Its
element-type has to be either (unsigned-byte 8) or character." element-type has to be either (unsigned-byte 8) or character."
(declare (optimize (speed 3) (space 0) (debug 0))) (declare (optimize (speed 3) (safety 3) (space 0) (debug 1)))
(let ((state (make-md5-state))) (locally
(declare (type md5-state state)) (declare (optimize (safety 1) (debug 0)))
(cond (let ((state (make-md5-state)))
((equal (stream-element-type stream) '(unsigned-byte 8)) (declare (type md5-state state))
(let ((buffer (make-array +buffer-size+ (cond
:element-type '(unsigned-byte 8)))) ((equal (stream-element-type stream) '(unsigned-byte 8))
(declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+)) (let ((buffer (make-array +buffer-size+
buffer)) :element-type '(unsigned-byte 8))))
(loop for bytes of-type buffer-index = (read-sequence buffer stream) (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+))
do (update-md5-state state buffer :end bytes) buffer))
until (< bytes +buffer-size+) (loop for bytes of-type buffer-index = (read-sequence buffer stream)
finally do (update-md5-state state buffer :end bytes)
(return (finalize-md5-state state))))) until (< bytes +buffer-size+)
((equal (stream-element-type stream) 'character) finally
(let ((buffer (make-string +buffer-size+))) (return (finalize-md5-state state)))))
(declare (type (simple-string #.+buffer-size+) buffer)) ((equal (stream-element-type stream) 'character)
(loop for bytes of-type buffer-index = (read-sequence buffer stream) (let ((buffer (make-string +buffer-size+)))
do (update-md5-state state buffer :end bytes) (declare (type (simple-string #.+buffer-size+) buffer))
until (< bytes +buffer-size+) (loop for bytes of-type buffer-index = (read-sequence buffer stream)
finally do (update-md5-state state buffer :end bytes)
(return (finalize-md5-state state))))) until (< bytes +buffer-size+)
(t finally
(error "Unsupported stream element-type ~S for stream ~S." (return (finalize-md5-state state)))))
(stream-element-type stream) stream))))) (t
(error "Unsupported stream element-type ~S for stream ~S."
(stream-element-type stream) stream))))))
(defun md5sum-file (pathname) (defun md5sum-file (pathname)
"Calculate the MD5 message-digest of the file specified by pathname." "Calculate the MD5 message-digest of the file specified by pathname."
(declare (optimize (speed 3) (space 0) (debug 0))) (declare (optimize (speed 3) (safety 3) (space 0) (debug 1)))
(with-open-file (stream pathname :element-type '(unsigned-byte 8)) (with-open-file (stream pathname :element-type '(unsigned-byte 8))
(md5sum-stream stream))) (md5sum-stream stream)))
@ -759,3 +794,7 @@ according to my additional test suite")
#+cmu #+cmu
(eval-when (:compile-toplevel) (eval-when (:compile-toplevel)
(setq ext:*inline-expansion-limit* *old-expansion-limit*)) (setq ext:*inline-expansion-limit* *old-expansion-limit*))
#+sbcl
(eval-when (:compile-toplevel)
(setq *features* *old-features*))