X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-md5%2Fmd5.lisp;h=ab006e978465551da528de1118709f5070903381;hb=ad3beba970fab6e451a461c9f9b14faf4ef17718;hp=e362f743902641d2538f4d833012eb7126457f03;hpb=98743008038a932dc6b53560d121df69c40e40ad;p=sbcl.git diff --git a/contrib/sb-md5/md5.lisp b/contrib/sb-md5/md5.lisp index e362f74..ab006e9 100644 --- a/contrib/sb-md5/md5.lisp +++ b/contrib/sb-md5/md5.lisp @@ -40,7 +40,7 @@ #:md5-state #:md5-state-p #:make-md5-state #:update-md5-state #:finalize-md5-state ;; High-Level functions on sequences, streams and files - #:md5sum-sequence #:md5sum-stream #:md5sum-file)) + #:md5sum-sequence #:md5sum-string #:md5sum-stream #:md5sum-file)) (in-package :SB-MD5) @@ -81,10 +81,7 @@ where a is the intended low-order byte and d the high-order byte." #+cmu (kernel:32bit-logical-or (kernel:32bit-logical-and x y) (kernel:32bit-logical-andc1 x z)) - #+sbcl - (sb-kernel:32bit-logical-or (sb-kernel:32bit-logical-and x y) - (sb-kernel:32bit-logical-andc1 x z)) - #-(or cmu sbcl) + #-cmu (logior (logand x y) (logandc1 x z))) (defun g (x y z) @@ -93,10 +90,7 @@ where a is the intended low-order byte and d the high-order byte." #+cmu (kernel:32bit-logical-or (kernel:32bit-logical-and x z) (kernel:32bit-logical-andc2 y z)) - #+sbcl - (sb-kernel:32bit-logical-or (sb-kernel:32bit-logical-and x z) - (sb-kernel:32bit-logical-andc2 y z)) - #-(or cmu sbcl) + #-cmu (logior (logand x z) (logandc2 y z))) (defun h (x y z) @@ -104,9 +98,7 @@ where a is the intended low-order byte and d the high-order byte." (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+cmu (kernel:32bit-logical-xor x (kernel:32bit-logical-xor y z)) - #+sbcl - (sb-kernel:32bit-logical-xor x (sb-kernel:32bit-logical-xor y z)) - #-(or cmu sbcl) + #-cmu (logxor x y z)) (defun i (x y z) @@ -114,9 +106,7 @@ where a is the intended low-order byte and d the high-order byte." (optimize (speed 3) (safety 0) (space 0) (debug 0))) #+cmu (kernel:32bit-logical-xor y (kernel:32bit-logical-orc2 x z)) - #+sbcl - (sb-kernel:32bit-logical-xor y (sb-kernel:32bit-logical-orc2 x z)) - #-(or cmu sbcl) + #-cmu (ldb (byte 32 0) (logxor y (logorc2 x z)))) (declaim (inline mod32+) @@ -129,11 +119,11 @@ where a is the intended low-order byte and d the high-order byte." (define-compiler-macro mod32+ (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 -;;; FIXME: Check whether this actually does the right thing on the -;;; alpha. (define-compiler-macro mod32+ (a b) - `(sb-ext:truly-the ub32 (+ ,a ,b))) + `(ldb (byte 32 0) (+ ,a ,b))) (declaim (inline rol32) (ftype (function (ub32 (unsigned-byte 5)) ub32) rol32)) @@ -287,11 +277,7 @@ starting from offset into the given 16 word MD5 block." block (* vm:vector-data-offset vm:word-bits) (* 64 vm:byte-bits)) #+(and :sbcl :little-endian) - (sb-kernel:bit-bash-copy - buffer (+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) - (* offset sb-vm:n-byte-bits)) - block (* sb-vm:vector-data-offset sb-vm:n-word-bits) - (* 64 sb-vm:n-byte-bits)) + (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 for j of-type (integer 0 #.most-positive-fixnum) @@ -316,11 +302,7 @@ offset into the given 16 word MD5 block." block (* vm:vector-data-offset vm:word-bits) (* 64 vm:byte-bits)) #+(and :sbcl :little-endian) - (sb-kernel:bit-bash-copy - buffer (+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) - (* offset sb-vm:n-byte-bits)) - block (* sb-vm:vector-data-offset sb-vm:n-word-bits) - (* 64 sb-vm:n-byte-bits)) + (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 for j of-type (integer 0 #.most-positive-fixnum) @@ -390,12 +372,7 @@ starting at buffer-offset." (* buffer-offset vm:byte-bits)) (* count vm:byte-bits)) #+sbcl - (sb-kernel:bit-bash-copy - from (+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) - (* from-offset sb-vm:n-byte-bits)) - buffer (+ (* sb-vm:vector-data-offset sb-vm:n-word-bits) - (* buffer-offset sb-vm:n-byte-bits)) - (* count sb-vm:n-byte-bits)) + (sb-kernel:ub8-bash-copy from from-offset buffer buffer-offset count) #-(or cmu sbcl) (etypecase from (simple-string @@ -526,25 +503,40 @@ The resulting MD5 message-digest is returned as an array of sixteen ;;; High-Level Drivers (defun md5sum-sequence (sequence &key (start 0) end) - "Calculate the MD5 message-digest of data in sequence. On CMU CL -this works for all sequences whose element-type is supported by the -underlying MD5 routines, on other implementations it only works for 1d -simple-arrays with such element types." - (declare (optimize (speed 3) (space 0) (debug 0)) - (type vector sequence) (type fixnum start)) - (let ((state (make-md5-state))) - (declare (type md5-state state)) - #+cmu - (lisp::with-array-data ((data sequence) (real-start start) (real-end end)) - (update-md5-state state data :start real-start :end real-end)) - #+sbcl - (sb-kernel:with-array-data ((data sequence) (real-start start) (real-end end)) - (update-md5-state state data :start real-start :end real-end)) - #-(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))) + "Calculate the MD5 message-digest of data bounded by START and END +in SEQUENCE , which must be a vector with element-type (UNSIGNED-BYTE +8)." + (declare (optimize (speed 3) (safety 3) (space 0) (debug 1)) + (type (vector (unsigned-byte 8)) sequence) (type fixnum start)) + (locally + (declare (optimize (safety 1) (debug 0))) + (let ((state (make-md5-state))) + (declare (type md5-state state)) + #+cmu + (lisp::with-array-data ((data sequence) (real-start start) (real-end end)) + (update-md5-state state data :start real-start :end real-end)) + #+sbcl + (sb-kernel:with-array-data ((data sequence) (real-start start) (real-end end)) + (update-md5-state state data :start real-start :end real-end)) + #-(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)))) + +(defun md5sum-string (string &key (external-format :default) (start 0) end) + "Calculate the MD5 message-digest of the binary representation +of STRING (as octets) in EXTERNAL-FORMAT. The boundaries START +and END refer to character positions in the string, not to octets +in the resulting binary representation." + (declare (optimize (speed 3) (safety 3) (space 0) (debug 1)) + (type string string) (type fixnum start)) + (locally + (declare (optimize (safety 1) (debug 0))) + (md5sum-sequence + (sb-ext:string-to-octets string + :external-format external-format + :start start :end end)))) (defconstant +buffer-size+ (* 128 1024) "Size of internal buffer to use for md5sum-stream and md5sum-file @@ -553,39 +545,46 @@ operations. This should be a multiple of 64, the MD5 block size.") (deftype buffer-index () `(integer 0 ,+buffer-size+)) (defun md5sum-stream (stream) - "Calculate an MD5 message-digest of the contents of stream. Its -element-type has to be either (unsigned-byte 8) or character." - (declare (optimize (speed 3) (space 0) (debug 0))) - (let ((state (make-md5-state))) - (declare (type md5-state state)) - (cond - ((equal (stream-element-type stream) '(unsigned-byte 8)) - (let ((buffer (make-array +buffer-size+ - :element-type '(unsigned-byte 8)))) - (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+)) - buffer)) - (loop for bytes of-type buffer-index = (read-sequence buffer stream) - do (update-md5-state state buffer :end bytes) - until (< bytes +buffer-size+) - finally - (return (finalize-md5-state state))))) - ((equal (stream-element-type stream) 'character) - (let ((buffer (make-string +buffer-size+))) - (declare (type (simple-string #.+buffer-size+) buffer)) - (loop for bytes of-type buffer-index = (read-sequence buffer stream) - do (update-md5-state state buffer :end bytes) - until (< bytes +buffer-size+) - finally - (return (finalize-md5-state state))))) - (t - (error "Unsupported stream element-type ~S for stream ~S." - (stream-element-type stream) stream))))) + "Calculate an MD5 message-digest of the contents of STREAM, whose +element-type has to be (UNSIGNED-BYTE 8)." + (declare (optimize (speed 3) (safety 3) (space 0) (debug 1))) + (declare (type stream stream)) + (locally + (declare (optimize (safety 1) (debug 0))) + (let ((state (make-md5-state))) + (declare (type md5-state state)) + (cond + ((equal (stream-element-type stream) '(unsigned-byte 8)) + (let ((buffer (make-array +buffer-size+ + :element-type '(unsigned-byte 8)))) + (declare (type (simple-array (unsigned-byte 8) (#.+buffer-size+)) + buffer)) + (loop for bytes of-type buffer-index = (read-sequence buffer stream) + do (update-md5-state state buffer :end bytes) + until (< bytes +buffer-size+) + finally + (return (finalize-md5-state state))))) + #+(or) + ((equal (stream-element-type stream) 'character) + (let ((buffer (make-string +buffer-size+))) + (declare (type (simple-string #.+buffer-size+) buffer)) + (loop for bytes of-type buffer-index = (read-sequence buffer stream) + do (update-md5-state state buffer :end bytes) + until (< bytes +buffer-size+) + finally + (return (finalize-md5-state state))))) + (t + (error "Unsupported stream element-type ~S for stream ~S." + (stream-element-type stream) stream)))))) (defun md5sum-file (pathname) - "Calculate the MD5 message-digest of the file specified by pathname." - (declare (optimize (speed 3) (space 0) (debug 0))) - (with-open-file (stream pathname :element-type '(unsigned-byte 8)) - (md5sum-stream stream))) + "Calculate the MD5 message-digest of the file designated by +pathname." + (declare (optimize (speed 3) (safety 3) (space 0) (debug 1))) + (locally + (declare (optimize (safety 1) (debug 0))) + (with-open-file (stream pathname :element-type '(unsigned-byte 8)) + (md5sum-stream stream)))) #+cmu (eval-when (:compile-toplevel :execute) @@ -597,4 +596,4 @@ element-type has to be either (unsigned-byte 8) or character." #+sbcl (eval-when (:compile-toplevel) - (setq *features* *old-features*)) \ No newline at end of file + (setq *features* *old-features*))