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

77
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)
@ -130,7 +141,9 @@ where a is the intended low-order byte and d the high-order byte."
(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,9 +405,9 @@ 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))
@ -448,7 +467,7 @@ bounded by start and end, which must be numeric bounding-indices."
#-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,9 +478,9 @@ 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))
@ -493,7 +512,7 @@ The resulting MD5 message-digest is returned as an array of sixteen
(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))
(locally
(declare (optimize (safety 1) (debug 0)))
(let ((state (make-md5-state))) (let ((state (make-md5-state)))
(declare (type md5-state state)) (declare (type md5-state state))
#+cmu #+cmu
(let ((end (or end (length sequence))))
(lisp::with-array-data ((data sequence) (real-start start) (real-end end)) (lisp::with-array-data ((data sequence) (real-start start) (real-end end))
(update-md5-state state data :start real-start :end real-end)) (declare (ignore real-end))
#-cmu (update-md5-state state data :start real-start
: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)))) (let ((real-end (or end (length sequence))))
(declare (type fixnum real-end)) (declare (type fixnum real-end))
(update-md5-state state sequence :start start :end real-end)) (update-md5-state state sequence :start start :end real-end))
(finalize-md5-state state))) (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,7 +558,9 @@ 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)))
(locally
(declare (optimize (safety 1) (debug 0)))
(let ((state (make-md5-state))) (let ((state (make-md5-state)))
(declare (type md5-state state)) (declare (type md5-state state))
(cond (cond
@ -549,11 +584,11 @@ element-type has to be either (unsigned-byte 8) or character."
(return (finalize-md5-state state))))) (return (finalize-md5-state state)))))
(t (t
(error "Unsupported stream element-type ~S for stream ~S." (error "Unsupported stream element-type ~S for stream ~S."
(stream-element-type stream) stream))))) (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*))