| ;;;; adler32.lisp - computing adler32 checksums (rfc1950) of a byte array (in-package :crypto) ;;; smallest prime < 65536 (defconstant adler32-modulo 65521) (defstruct (adler32-state (:constructor make-adler32-state) (:copier copy-adler32-state)) (s1 1 :type fixnum) (s2 0 :type fixnum)) (defun update-adler32-state (state sequence &key (start 0) (end (length sequence))) (declare (type adler32-state state) (type (simple-array (unsigned-byte 8) (*)) sequence) (type index start end)) ;; many thanks to Xach for his code from Salza. (let ((length (- end start)) (i 0) (k 0) (s1 (adler32-state-s1 state)) (s2 (adler32-state-s2 state))) (declare (type index i k length) (type fixnum s1 s2)) (unless (zerop length) (tagbody loop (setf k (min 16 length)) (decf length k) sum (setf s1 (+ (aref sequence (+ start i)) s1)) (setf s2 (+ s1 s2)) (decf k) (incf i) (unless (zerop k) (go sum)) (setf s1 (mod s1 adler32-modulo)) (setf s2 (mod s2 adler32-modulo)) (unless (zerop length) (go loop)) end (setf (adler32-state-s1 state) s1 (adler32-state-s2 state) s2) (return-from update-adler32-state state))))) (define-digest-finalizer adler32 4 (flet ((stuff-state (state digest start) (declare (type (simple-array (unsigned-byte 8) (*)) digest)) (declare (type (integer 0 #.(- array-dimension-limit 4)) start)) (setf (ub32ref/be digest start) (logior (ash (adler32-state-s2 state) 16) (adler32-state-s1 state))) digest)) (declare (inline stuff-state)) (cond (%buffer (stuff-state state %buffer buffer-start)) (t (stuff-state state (make-array 4 :element-type '(unsigned-byte 8)) 0))))) (defdigest adler32 (:digest-length 4) (:state-type adler32-state) (:creation-function make-adler32-state) (:copy-function copy-adler32-state) (:update-function update-adler32-state) (:finalize-function finalize-adler32-state)) |