;;;; adler32.lisp - computing adler32 checksums (rfc1950) of a byte array
;;;
;;; Author: Nathan Froyd <froydnj@cs.rice.edu>, BSD license
;;;
;;; This implementation should work with minimal consing on all
;;; Common Lisp implementations with reasonable implementations of fixnums.

(defpackage #:adler32
  (:use :cl)
  (:export
   ;; types
   #:adler32
   ;; computing adler32 in a rolling fashion
   #:make-adler32 #:update-adler32 #:finalize-adler32
   ;; computing adler32 all in one go
   #:adler32-checksum)
  (:documentation "Computing the adler32 checksum of sequences."))

(in-package #:adler32)

;;; smallest prime < 65536
(defconstant adler32-modulo 65521)

(defstruct adler32
  (s1 1 :type fixnum)
  (s2 0 :type fixnum)
  (length 0 :type fixnum))

(defun update-adler32 (adler32 vector &key (start 0) (end (length vector)))
  "Update the internal state of ADLER32 with the elements of VECTOR
bounded by START and END.  VECTOR should contain elements of either
type BASE-CHAR or of type (UNSIGNED-BYTE 8)."
  (declare (type adler32 adler32))
  #+sbcl (declare (type sb-int:index start end))
  (declare (optimize (speed 3) (safety 1) (space 0)))
  (let ((s1 (adler32-s1 adler32))
        (s2 (adler32-s2 adler32))
        (length (adler32-length adler32)))
    (declare (type fixnum s1 s2 length))
    (flet ((frob-buffer (frob-fun buffer start end)
             ;; This loop could be unrolled for better performance.
             (do ((i start (1+ i)))
                 ((= i end)
                  (setf (adler32-s1 adler32) (logand s1 #xffff)
                        (adler32-s2 adler32) (logand s2 #xffff)
                        (adler32-length adler32) length)
                  adler32)
               (setf s1 (+ s1 (funcall frob-fun (aref buffer i)))
                     s2 (+ s2 s1))
               (incf length)
               (when (= length 5552)
                 (setf s1 (truncate s1 adler32-modulo)
                       s2 (truncate s2 adler32-modulo)
                       length 0)))))
      (declare (inline frob-buffer))
      (etypecase vector
        ((simple-array (unsigned-byte 8) (*))
         (locally
             (declare (type (simple-array (unsigned-byte 8) (*)) vector))
           (frob-buffer #'identity vector start end)))
        (simple-base-string
         (locally
             (declare (type simple-base-string vector))
           (frob-buffer #'char-code vector start end)))))))


(defun finalize-adler32 (adler32)
  "Return the final 32-bit checksum stored in ADLER32."
  (logior (ash (adler32-s2 adler32) 16)
          (adler32-s1 adler32)))

(defun adler32-checksum (sequence &key (start 0) (end (length sequence)))
  "Compute the adler32 checksum of SEQUENCE bounded by START and END.
On CMU CL and SBCL, this function works for all array-based sequences
whose element-type is supported by UPDATE-ADLER32.  On other implementations,
this function will only work for 1d simple-arrays with such element-types."
  (declare (type vector sequence))
  (let ((adler32 (make-adler32)))
    #+cmu
    (lisp::with-array-data ((buffer sequence) (start start) (end end))
      (update-adler32 adler32 buffer :start start :end end))
    #+sbcl
    (sb-kernel:with-array-data ((buffer sequence) (start start) (end end))
      (update-adler32 adler32 buffer :start start :end end))
    #-(or cmu sbcl)
    (update-adler32 adler32 sequence :start start :end end)
    (finalize-adler32 adler32)))