;;;; 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))
    (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))))

(defun finalize-adler32-state (state)
  (declare (type adler32-state state))
  (let ((digest (make-array 4 :element-type '(unsigned-byte 8))))
    (setf (ub32ref/be digest 0)
          (logior (ash (adler32-state-s2 state) 16)
                  (adler32-state-s1 state)))
    digest))

(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))
