;;;============================================================================

;;; File: "digest.scm", Time-stamp: <2007-04-05 00:51:05 feeley>

;;; Copyright (c) 2006-2007 by Marc Feeley, All Rights Reserved.

;;;============================================================================

;;; Contains procedures to compute message digests.

(package* digest/v1.0.1
 (provide:

  (define (open-digest algorithm))

  (define* (close-digest digest (result-type _)))

  (define (digest-update-subu8vector digest u8vect start end))
  (define (digest-update-u8 digest n))     ;; assumes n is a fixnum
  (define (digest-update-u16-le digest n)) ;; assumes n is a fixnum
  (define (digest-update-u16-be digest n)) ;; assumes n is a fixnum
  (define (digest-update-u32-le digest n)) ;; assumes n is a fixnum
  (define (digest-update-u32-be digest n)) ;; assumes n is a fixnum

  (define* (digest-string str algorithm (result-type _)))
  (define* (digest-substring str start end algorithm (result-type _)))
  (define* (digest-u8vector u8vect algorithm (result-type _)))
  (define* (digest-subu8vector u8vect start end algorithm (result-type _)))
  (define* (digest-file filename algorithm (result-type _))))

 (maintainer:
  "Scheme Now! <snow at iro.umontreal.ca>")

 (author:
  "Marc Feeley <feeley at iro.umontreal.ca>")

 (homepage:
  "http://snow.iro.umontreal.ca")

 (description:
  "Computation of message digests (CRC32, MD5, SHA-1, ...).")

 (keywords: hash conv snow)

 (license: lgpl/v2.1)

 (require: fixnum/v1)
 (require: homovector/v1)
 (require: binio/v1))

;; TODO: change the interface so that a "digest" is really a generic
;; port.  This way the I/O procedures can be used to feed the content
;; of the message to digest (for example genport-write-subu8vector
;; will subsume digest-update-subu8vector).

;;;============================================================================

(cond-expand

 (gambit

  (declare
   (standard-bindings)
   (fixnum)
   (not safe)))

 (else

  #f))

(define-record* digest
  ;; uid: digest-40fc963a-8d31-4f76-ac43-e208509bed1b
  end
  update
  state)

(define (hex8 n) ;; assumes n is a fixnum
  (substring (number->string (+ n #x100) 16) 1 3))

(define (hex16 n) ;; assumes n is a fixnum
  (substring (number->string (+ n #x10000) 16) 1 5))

;;;----------------------------------------------------------------------------

;; CRC32 digest.

(define-record* crc32-digest
  ;; uid: crc32-digest-2a3353e7-767f-4803-8f2e-3f1b8cf4abde
  hi16
  lo16)

(define crc32-table '#(
#x0000 #x0000 #x7707 #x3096 #xEE0E #x612C #x9909 #x51BA
#x076D #xC419 #x706A #xF48F #xE963 #xA535 #x9E64 #x95A3
#x0EDB #x8832 #x79DC #xB8A4 #xE0D5 #xE91E #x97D2 #xD988
#x09B6 #x4C2B #x7EB1 #x7CBD #xE7B8 #x2D07 #x90BF #x1D91
#x1DB7 #x1064 #x6AB0 #x20F2 #xF3B9 #x7148 #x84BE #x41DE
#x1ADA #xD47D #x6DDD #xE4EB #xF4D4 #xB551 #x83D3 #x85C7
#x136C #x9856 #x646B #xA8C0 #xFD62 #xF97A #x8A65 #xC9EC
#x1401 #x5C4F #x6306 #x6CD9 #xFA0F #x3D63 #x8D08 #x0DF5
#x3B6E #x20C8 #x4C69 #x105E #xD560 #x41E4 #xA267 #x7172
#x3C03 #xE4D1 #x4B04 #xD447 #xD20D #x85FD #xA50A #xB56B
#x35B5 #xA8FA #x42B2 #x986C #xDBBB #xC9D6 #xACBC #xF940
#x32D8 #x6CE3 #x45DF #x5C75 #xDCD6 #x0DCF #xABD1 #x3D59
#x26D9 #x30AC #x51DE #x003A #xC8D7 #x5180 #xBFD0 #x6116
#x21B4 #xF4B5 #x56B3 #xC423 #xCFBA #x9599 #xB8BD #xA50F
#x2802 #xB89E #x5F05 #x8808 #xC60C #xD9B2 #xB10B #xE924
#x2F6F #x7C87 #x5868 #x4C11 #xC161 #x1DAB #xB666 #x2D3D
#x76DC #x4190 #x01DB #x7106 #x98D2 #x20BC #xEFD5 #x102A
#x71B1 #x8589 #x06B6 #xB51F #x9FBF #xE4A5 #xE8B8 #xD433
#x7807 #xC9A2 #x0F00 #xF934 #x9609 #xA88E #xE10E #x9818
#x7F6A #x0DBB #x086D #x3D2D #x9164 #x6C97 #xE663 #x5C01
#x6B6B #x51F4 #x1C6C #x6162 #x8565 #x30D8 #xF262 #x004E
#x6C06 #x95ED #x1B01 #xA57B #x8208 #xF4C1 #xF50F #xC457
#x65B0 #xD9C6 #x12B7 #xE950 #x8BBE #xB8EA #xFCB9 #x887C
#x62DD #x1DDF #x15DA #x2D49 #x8CD3 #x7CF3 #xFBD4 #x4C65
#x4DB2 #x6158 #x3AB5 #x51CE #xA3BC #x0074 #xD4BB #x30E2
#x4ADF #xA541 #x3DD8 #x95D7 #xA4D1 #xC46D #xD3D6 #xF4FB
#x4369 #xE96A #x346E #xD9FC #xAD67 #x8846 #xDA60 #xB8D0
#x4404 #x2D73 #x3303 #x1DE5 #xAA0A #x4C5F #xDD0D #x7CC9
#x5005 #x713C #x2702 #x41AA #xBE0B #x1010 #xC90C #x2086
#x5768 #xB525 #x206F #x85B3 #xB966 #xD409 #xCE61 #xE49F
#x5EDE #xF90E #x29D9 #xC998 #xB0D0 #x9822 #xC7D7 #xA8B4
#x59B3 #x3D17 #x2EB4 #x0D81 #xB7BD #x5C3B #xC0BA #x6CAD
#xEDB8 #x8320 #x9ABF #xB3B6 #x03B6 #xE20C #x74B1 #xD29A
#xEAD5 #x4739 #x9DD2 #x77AF #x04DB #x2615 #x73DC #x1683
#xE363 #x0B12 #x9464 #x3B84 #x0D6D #x6A3E #x7A6A #x5AA8
#xE40E #xCF0B #x9309 #xFF9D #x0A00 #xAE27 #x7D07 #x9EB1
#xF00F #x9344 #x8708 #xA3D2 #x1E01 #xF268 #x6906 #xC2FE
#xF762 #x575D #x8065 #x67CB #x196C #x3671 #x6E6B #x06E7
#xFED4 #x1B76 #x89D3 #x2BE0 #x10DA #x7A5A #x67DD #x4ACC
#xF9B9 #xDF6F #x8EBE #xEFF9 #x17B7 #xBE43 #x60B0 #x8ED5
#xD6D6 #xA3E8 #xA1D1 #x937E #x38D8 #xC2C4 #x4FDF #xF252
#xD1BB #x67F1 #xA6BC #x5767 #x3FB5 #x06DD #x48B2 #x364B
#xD80D #x2BDA #xAF0A #x1B4C #x3603 #x4AF6 #x4104 #x7A60
#xDF60 #xEFC3 #xA867 #xDF55 #x316E #x8EEF #x4669 #xBE79
#xCB61 #xB38C #xBC66 #x831A #x256F #xD2A0 #x5268 #xE236
#xCC0C #x7795 #xBB0B #x4703 #x2202 #x16B9 #x5505 #x262F
#xC5BA #x3BBE #xB2BD #x0B28 #x2BB4 #x5A92 #x5CB3 #x6A04
#xC2D7 #xFFA7 #xB5D0 #xCF31 #x2CD9 #x9E8B #x5BDE #xAE1D
#x9B64 #xC2B0 #xEC63 #xF226 #x756A #xA39C #x026D #x930A
#x9C09 #x06A9 #xEB0E #x363F #x7207 #x6785 #x0500 #x5713
#x95BF #x4A82 #xE2B8 #x7A14 #x7BB1 #x2BAE #x0CB6 #x1B38
#x92D2 #x8E9B #xE5D5 #xBE0D #x7CDC #xEFB7 #x0BDB #xDF21
#x86D3 #xD2D4 #xF1D4 #xE242 #x68DD #xB3F8 #x1FDA #x836E
#x81BE #x16CD #xF6B9 #x265B #x6FB0 #x77E1 #x18B7 #x4777
#x8808 #x5AE6 #xFF0F #x6A70 #x6606 #x3BCA #x1101 #x0B5C
#x8F65 #x9EFF #xF862 #xAE69 #x616B #xFFD3 #x166C #xCF45
#xA00A #xE278 #xD70D #xD2EE #x4E04 #x8354 #x3903 #xB3C2
#xA767 #x2661 #xD060 #x16F7 #x4969 #x474D #x3E6E #x77DB
#xAED1 #x6A4A #xD9D6 #x5ADC #x40DF #x0B66 #x37D8 #x3BF0
#xA9BC #xAE53 #xDEBB #x9EC5 #x47B2 #xCF7F #x30B5 #xFFE9
#xBDBD #xF21C #xCABA #xC28A #x53B3 #x9330 #x24B4 #xA3A6
#xBAD0 #x3605 #xCDD7 #x0693 #x54DE #x5729 #x23D9 #x67BF
#xB366 #x7A2E #xC461 #x4AB8 #x5D68 #x1B02 #x2A6F #x2B94
#xB40B #xBE37 #xC30C #x8EA1 #x5A05 #xDF1B #x2D02 #xEF8D
))

(define (digest-update-crc32 digest u8vect start end)
  (let ((state (digest-state digest)))
    (let ((hi16 (crc32-digest-hi16 state))
          (lo16 (crc32-digest-lo16 state)))
      (let loop ((i start)
                 (hi hi16)
                 (lo lo16))
        (if (< i end)
            (let* ((x (snow-u8vector-ref u8vect i))
                   (j (* 2 (snow-fxand (snow-fxxor lo x) #xff)))
                   (crc-hi (vector-ref crc32-table j))
                   (crc-lo (vector-ref crc32-table (+ j 1))))
              (loop (+ i 1)
                    (snow-fxxor
                     crc-hi
                     (snow-fxarithmetic-shift-right hi 8))
                    (snow-fxxor
                     crc-lo
                     (+ (snow-fxarithmetic-shift-left (snow-fxand hi #xff) 8)
                        (snow-fxarithmetic-shift-right lo 8)))))
            (begin
              (crc32-digest-hi16-set! state hi)
              (crc32-digest-lo16-set! state lo)))))))

(define (end-crc32 digest result-type)
  (let ((state (digest-state digest)))
    (let ((hi16 (snow-fxxor (crc32-digest-hi16 state) #xffff))
          (lo16 (snow-fxxor (crc32-digest-lo16 state) #xffff)))
      (case result-type
        ((hex)
         (string-append (hex16 hi16) (hex16 lo16)))
        ((u8vector)
         (snow-u8vector (snow-fxand #xff lo16)
                        (snow-fxarithmetic-shift-right lo16 8)
                        (snow-fxand #xff hi16)
                        (snow-fxarithmetic-shift-right hi16 8)))
        (else
         (snow-error "unsupported digest result-type" result-type))))))

(define (open-digest-crc32)
  (make-digest
   end-crc32
   digest-update-crc32
   (make-crc32-digest #xffff #xffff)))

;; Useful for debugging:
;;
;;(define crc32-poly #xEDB88320)
;;
;;(define crc32-table-computed
;;  (let ((v (make-vector 512)))
;;    (let loop1 ((n 0))
;;      (if (< n 256)
;;          (let loop2 ((k 0) (c n))
;;            (if (< k 8)
;;                (loop2 (+ k 1)
;;                       (if (odd? c)
;;                           (bitwise-xor crc32-poly
;;                                        (arithmetic-shift c -1))
;;                           (arithmetic-shift c -1)))
;;                (begin
;;                  (vector-set! v (* n 2) (arithmetic-shift c -16))
;;                  (vector-set! v (+ 1 (* n 2)) (bitwise-and c #xffff))
;;                  (loop1 (+ n 1)))))))
;;    v))
;;
;;(if (not (equal? crc32-table-computed crc32-table))
;;    (snow-error "crc32-table is incorrect"))
;;
;;(define (digest-update-crc32 digest u8vect start end)
;;  (let ((state (digest-state digest)))
;;    (let ((hi16 (crc32-digest-hi16 state))
;;          (lo16 (crc32-digest-lo16 state)))
;;      (let loop ((i start)
;;                 (crc (+ (arithmetic-shift hi16 16)
;;                         lo16)))
;;        (if (< i end)
;;            (let* ((x (snow-u8vector-ref u8vect i))
;;                   (crc (bitwise-xor crc x)))
;;              (let loop2 ((j 8) (crc crc))
;;                (if (> j 0)
;;                    (loop2 (- j 1)
;;                           (if (odd? crc)
;;                               (bitwise-xor crc32-poly
;;                                            (arithmetic-shift crc -1))
;;                               (arithmetic-shift crc -1)))
;;                    (loop (+ i 1)
;;                          crc))))
;;            (begin
;;              (crc32-digest-hi16-set!
;;               state
;;               (arithmetic-shift crc -16))
;;              (crc32-digest-lo16-set!
;;               state
;;               (bitwise-and crc #xffff))))))))

;;;----------------------------------------------------------------------------

(define (hash-block->hex-string hb big-endian? width)

  (define (hex x)
    (string-ref "0123456789abcdef" (snow-fxand x 15)))

  (let* ((len (quotient width 16))
         (n (* len 4))
         (str (make-string n)))
    (let loop ((i (- len 1)) (j (- n 4)))
      (if (< i 0)
          str
          (let ((x (vector-ref hb (if big-endian? (snow-fxxor i 1) i)))
                (j1 (if big-endian? (+ j 0) (+ j 2)))
                (j2 (if big-endian? (+ j 2) (+ j 0))))
            (string-set!
             str
             (+ j1 0)
             (hex (snow-fxarithmetic-shift-right x 12)))
            (string-set!
             str
             (+ j1 1)
             (hex (snow-fxarithmetic-shift-right x 8)))
            (string-set!
             str
             (+ j2 0)
             (hex (snow-fxarithmetic-shift-right x 4)))
            (string-set!
             str
             (+ j2 1)
             (hex (snow-fxarithmetic-shift-right x 0)))
            (loop (- i 1) (- j 4)))))))

(define (hash-block->u8vector hb big-endian? width)
  (let* ((len (quotient width 16))
         (n (* len 2))
         (u8vect (snow-make-u8vector n 0)))
    (let loop ((i (- len 1)) (j (- n 2)))
      (if (< i 0)
          u8vect
          (let ((x (vector-ref hb (if big-endian? (snow-fxxor i 1) i)))
                (j1 (if big-endian? (+ j 0) (+ j 1)))
                (j2 (if big-endian? (+ j 1) (+ j 0))))
            (snow-u8vector-set! u8vect j1 (snow-fxarithmetic-shift-right x 8))
            (snow-u8vector-set! u8vect j2 (snow-fxand #xff x))
            (loop (- i 1) (- j 2)))))))

(define-macro (LO var)
  (string->symbol
   (string-append (symbol->string var) "-" (symbol->string 'L))))

(define-macro (HI var)
  (string->symbol
   (string-append (symbol->string var) "-" (symbol->string 'H))))

(define-macro (wlet var lo hi body)
  `(let ((,(string->symbol
            (string-append (symbol->string var) "-" (symbol->string 'L)))
          ,lo)
         (,(string->symbol
            (string-append (symbol->string var) "-" (symbol->string 'H)))
          ,hi))
     ,body))

(define-macro (cast-u16 x)
  `(snow-fxand #xffff ,x))

(define-macro (shift-left-u16 n shift)
  `(snow-fxarithmetic-shift-left
    (snow-fxand ,n ,(- (expt 2 (- 16 shift)) 1))
    ,shift))

(define-macro (wshr dst w r body)
  (if (< r 16)
      `(wlet ,dst
             (snow-fxior
              (snow-fxarithmetic-shift-right (LO ,w) ,r)
              (shift-left-u16 (HI ,w) ,(- 16 r)))
             (snow-fxarithmetic-shift-right (HI ,w) ,r)
             ,body)
      `(wlet ,dst
             (snow-fxarithmetic-shift-right (HI ,w) ,(- r 16))
             0
             ,body)))

(define-macro (wrot dst w r body)
  (if (< r 16)
      `(wlet ,dst
             (snow-fxior
              (shift-left-u16 (LO ,w) ,r)
              (snow-fxarithmetic-shift-right (HI ,w) ,(- 16 r)))
             (snow-fxior
              (shift-left-u16 (HI ,w) ,r)
              (snow-fxarithmetic-shift-right (LO ,w) ,(- 16 r)))
             ,body)
      `(wlet ,dst
             (snow-fxior
              (shift-left-u16 (HI ,w) ,(- r 16))
              (snow-fxarithmetic-shift-right (LO ,w) ,(- 32 r)))
             (snow-fxior
              (shift-left-u16 (LO ,w) ,(- r 16))
              (snow-fxarithmetic-shift-right (HI ,w) ,(- 32 r)))
             ,body)))

(define-macro (wadd dst a b body)
  `(wlet R
         (+ (LO ,a) (LO ,b))
         (+ (HI ,a) (HI ,b))
         (wlet ,dst
               (cast-u16 (LO R))
               (cast-u16
                (+ (HI R)
                   (snow-fxarithmetic-shift-right (LO R) 16)))
               ,body)))

(define-macro (wxor dst a b body)
  `(wlet ,dst
         (snow-fxxor (LO ,a) (LO ,b))
         (snow-fxxor (HI ,a) (HI ,b))
         ,body))

(define-macro (wior dst a b body)
  `(wlet ,dst
         (snow-fxior (LO ,a) (LO ,b))
         (snow-fxior (HI ,a) (HI ,b))
         ,body))

(define-macro (wand dst a b body)
  `(wlet ,dst
         (snow-fxand (LO ,a) (LO ,b))
         (snow-fxand (HI ,a) (HI ,b))
         ,body))

(define-macro (wnot dst a body)
  `(wlet ,dst
         (snow-fxnot (LO ,a))
         (snow-fxnot (HI ,a))
         ,body))

(define-macro (wref dst v i body)
  (if (number? i)
      `(wlet ,dst
             (vector-ref ,v ,(+ (* 2 i) 0))
             (vector-ref ,v ,(+ (* 2 i) 1))
             ,body)
      `(wlet ,dst
             (vector-ref ,v (+ (* 2 ,i) 0))
             (vector-ref ,v (+ (* 2 ,i) 1))
             ,body)))

(define-macro (wset v i x)
  (if (number? i)
      `(begin
         (vector-set! ,v ,(+ (* 2 i) 0) (LO ,x))
         (vector-set! ,v ,(+ (* 2 i) 1) (HI ,x)))
      `(begin
         (vector-set! ,v (+ (* 2 ,i) 0) (LO ,x))
         (vector-set! ,v (+ (* 2 ,i) 1) (HI ,x)))))

;;;----------------------------------------------------------------------------

(define-record* block-digest
  ;; uid: block-digest-7ed6b9af-6463-4a06-89d6-b1991da46b87
  hash-update
  hash
  block
  block-pos
  bit-pos
  big-endian?
  width)

(define (convert-hash-block digest result-type)
  (let* ((bd (digest-state digest))
         (hash (block-digest-hash bd)))
    (case result-type
      ((hex)
       (hash-block->hex-string
        hash
        (block-digest-big-endian? bd)
        (block-digest-width bd)))
      ((u8vector)
       (hash-block->u8vector
        hash
        (block-digest-big-endian? bd)
        (block-digest-width bd)))
      (else
       (snow-error "unsupported digest result-type" result-type)))))

(define (process-last-block digest)
  (let* ((bd
          (digest-state digest))
         (block-pos
          (block-digest-block-pos bd))
         (bit-pos
          (block-digest-bit-pos bd))
         (buf
          (snow-make-u8vector 8 0)))

    (digest-update-u8 digest #x80) ;; add byte-aligned 1 bit

    (let ((zero-padding-bytes
           (quotient
            (snow-fxand 511 (- 448 (block-digest-bit-pos bd)))
            8)))
      (let loop1 ((n zero-padding-bytes))
        (if (< 0 n)
            (let ((m (min 8 n)))
              (digest-update-subu8vector
               digest
               buf
               0
               m) ;; add 0 bits
              (loop1 (- n m))))))

    (snow-u8vector-set!
     buf
     0
     (snow-fxand #xff bit-pos))

    (snow-u8vector-set!
     buf
     1
     (snow-fxior
      (snow-fxarithmetic-shift-left (snow-fxand #x7f block-pos) 1)
      (snow-fxand #x01 (snow-fxarithmetic-shift-right bit-pos 8))))

    (let loop2 ((i 2)
                (n (snow-fxarithmetic-shift-right block-pos 7)))
      (if (> n 0)
          (begin
            (snow-u8vector-set! buf i (snow-fxand #xff n))
            (loop2 (+ i 1)
                   (snow-fxarithmetic-shift-right n 8)))))

    (if (block-digest-big-endian? bd)
        (let loop3 ((i 3))
          (if (>= i 0)
              (let ((t (snow-u8vector-ref buf i)))
                (snow-u8vector-set! buf i (snow-u8vector-ref buf (- 7 i)))
                (snow-u8vector-set! buf (- 7 i) t)
                (loop3 (- i 1))))))

    (digest-update-subu8vector digest buf 0 8)));; add message length (in bits)

(define (end-block-digest digest result-type)
  (process-last-block digest)
  (convert-hash-block digest result-type))

(define (digest-update-block-digest digest u8vect start end)
  (let* ((bd (digest-state digest))
         (block (block-digest-block bd)))

    (define (aligned8 i bit-pos)

      ;; bit-pos is a multiple of 8

      (if (< i end)
          (let ((j (snow-fxarithmetic-shift-right bit-pos 4)))
            (if (= 0 (snow-fxand bit-pos 15))
                (begin
                  (if (block-digest-big-endian? bd)
                      (let ((j (snow-fxxor j 1)))
                        (vector-set!
                         block
                         j
                         (snow-fxarithmetic-shift-left
                          (snow-u8vector-ref u8vect i)
                          8)))
                      (vector-set!
                       block
                       j
                       (snow-u8vector-ref u8vect i)))
                  (let ((new-bit-pos (+ bit-pos 8)))
                    (aligned8 (+ i 1) new-bit-pos)))
                (begin
                  (if (block-digest-big-endian? bd)
                      (let ((j (snow-fxxor j 1)))
                        (vector-set!
                         block
                         j
                         (+ (vector-ref block j)
                            (snow-u8vector-ref u8vect i))))
                      (vector-set!
                       block
                       j
                       (+ (vector-ref block j)
                          (snow-fxarithmetic-shift-left
                           (snow-u8vector-ref u8vect i)
                           8))))
                  (let ((new-bit-pos (+ bit-pos 8)))
                    (if (= 512 new-bit-pos)
                      (begin
                        ((block-digest-hash-update bd) digest)
                        (block-digest-block-pos-set!
                         bd
                         (+ (block-digest-block-pos bd) 1))
                        (aligned16 (+ i 1) 0))
                      (aligned16 (+ i 1) new-bit-pos))))))
          (block-digest-bit-pos-set! bd bit-pos)))

    (define (aligned16 i bit-pos)

      ;; bit-pos is a multiple of 16

      (if (< (+ i 1) end)
          (let ((j (snow-fxarithmetic-shift-right bit-pos 4)))
            (if (block-digest-big-endian? bd)
                (let ((j (snow-fxxor j 1)))
                  (vector-set!
                   block
                   j
                   (+
                    (snow-fxarithmetic-shift-left
                     (snow-u8vector-ref u8vect i)
                     8)
                    (snow-u8vector-ref u8vect (+ i 1)))))
                (vector-set!
                 block
                 j
                 (+
                  (snow-fxarithmetic-shift-left
                   (snow-u8vector-ref u8vect (+ i 1))
                   8)
                  (snow-u8vector-ref u8vect i))))
            (let ((new-bit-pos (+ bit-pos 16)))
              (if (= 512 new-bit-pos)
                  (begin
                    ((block-digest-hash-update bd) digest)
                    (block-digest-block-pos-set!
                     bd
                     (+ (block-digest-block-pos bd) 1))
                    (aligned16 (+ i 2) 0))
                  (aligned16 (+ i 2) new-bit-pos))))
          (aligned8 i bit-pos)))

    (let ((bit-pos (block-digest-bit-pos bd)))
      (cond ((= 0 (snow-fxand bit-pos 15)) ;; 16 bit boundary?
             (aligned16 start bit-pos))
            (else
             ;; (= 0 (snow-fxand bit-pos 7)) ;; 8 bit boundary?
             (aligned8 start bit-pos))))))

;;;----------------------------------------------------------------------------

;; MD5 digest.

(define (hash-block-init-md5)
  (vector #x2301 #x6745
          #xab89 #xefcd
          #xdcfe #x98ba
          #x5476 #x1032))

(define-macro (wstp dst w f i n-hi16 n-lo16 r body)
  `(wlet T1
         ,(cons (car f) (map (lambda (v) `(LO ,v)) (cdr f)))
         ,(cons (car f) (map (lambda (v) `(HI ,v)) (cdr f)))
   (wadd T2 ,dst T1
   (wref T3 block ,i
   (wadd T4 T2 T3
   (wlet T5
         ,n-lo16
         ,n-hi16
   (wadd T6 T4 T5
   (wrot T7 T6 ,r
   (wadd ,dst ,w T7
         ,body)))))))))

(define-macro (fn-F x y z)
  `(snow-fxior
    (snow-fxand ,x ,y)
    (snow-fxand (snow-fxnot ,x) ,z)))

(define-macro (fn-G x y z)
  `(snow-fxior
    (snow-fxand ,x ,z)
    (snow-fxand ,y (snow-fxnot ,z))))

(define-macro (fn-H x y z)
  `(snow-fxxor ,x (snow-fxxor ,y ,z)))

(define-macro (fn-I x y z)
  `(cast-u16
    (snow-fxxor
     ,y
     (snow-fxior
      ,x
      (snow-fxnot ,z)))))

(define (digest-update-md5 digest)
  (let* ((bd (digest-state digest))
         (hash (block-digest-hash bd))
         (block (block-digest-block bd)))

    (define (stage1 A-L A-H B-L B-H C-L C-H D-L D-H)
      (wstp A B (fn-F B C D)  0 #xD76A #xA478  7
      (wstp D A (fn-F A B C)  1 #xE8C7 #xB756 12
      (wstp C D (fn-F D A B)  2 #x2420 #x70DB 17
      (wstp B C (fn-F C D A)  3 #xC1BD #xCEEE 22
      (wstp A B (fn-F B C D)  4 #xF57C #x0FAF  7
      (wstp D A (fn-F A B C)  5 #x4787 #xC62A 12
      (wstp C D (fn-F D A B)  6 #xA830 #x4613 17
      (wstp B C (fn-F C D A)  7 #xFD46 #x9501 22
      (stage2 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))

    (define (stage2 A-L A-H B-L B-H C-L C-H D-L D-H)
      (wstp A B (fn-F B C D)  8 #x6980 #x98D8  7
      (wstp D A (fn-F A B C)  9 #x8B44 #xF7AF 12
      (wstp C D (fn-F D A B) 10 #xFFFF #x5BB1 17
      (wstp B C (fn-F C D A) 11 #x895C #xD7BE 22
      (wstp A B (fn-F B C D) 12 #x6B90 #x1122  7
      (wstp D A (fn-F A B C) 13 #xFD98 #x7193 12
      (wstp C D (fn-F D A B) 14 #xA679 #x438E 17
      (wstp B C (fn-F C D A) 15 #x49B4 #x0821 22
      (stage3 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))

    (define (stage3 A-L A-H B-L B-H C-L C-H D-L D-H)
      (wstp A B (fn-G B C D)  1 #xF61E #x2562  5
      (wstp D A (fn-G A B C)  6 #xC040 #xB340  9
      (wstp C D (fn-G D A B) 11 #x265E #x5A51 14
      (wstp B C (fn-G C D A)  0 #xE9B6 #xC7AA 20
      (wstp A B (fn-G B C D)  5 #xD62F #x105D  5
      (wstp D A (fn-G A B C) 10 #x0244 #x1453  9
      (wstp C D (fn-G D A B) 15 #xD8A1 #xE681 14
      (wstp B C (fn-G C D A)  4 #xE7D3 #xFBC8 20
      (stage4 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))

    (define (stage4 A-L A-H B-L B-H C-L C-H D-L D-H)
      (wstp A B (fn-G B C D)  9 #x21E1 #xCDE6  5
      (wstp D A (fn-G A B C) 14 #xC337 #x07D6  9
      (wstp C D (fn-G D A B)  3 #xF4D5 #x0D87 14
      (wstp B C (fn-G C D A)  8 #x455A #x14ED 20
      (wstp A B (fn-G B C D) 13 #xA9E3 #xE905  5
      (wstp D A (fn-G A B C)  2 #xFCEF #xA3F8  9
      (wstp C D (fn-G D A B)  7 #x676F #x02D9 14
      (wstp B C (fn-G C D A) 12 #x8D2A #x4C8A 20
      (stage5 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))

    (define (stage5 A-L A-H B-L B-H C-L C-H D-L D-H)
      (wstp A B (fn-H B C D)  5 #xFFFA #x3942  4
      (wstp D A (fn-H A B C)  8 #x8771 #xF681 11
      (wstp C D (fn-H D A B) 11 #x6D9D #x6122 16
      (wstp B C (fn-H C D A) 14 #xFDE5 #x380C 23
      (wstp A B (fn-H B C D)  1 #xA4BE #xEA44  4
      (wstp D A (fn-H A B C)  4 #x4BDE #xCFA9 11
      (wstp C D (fn-H D A B)  7 #xF6BB #x4B60 16
      (wstp B C (fn-H C D A) 10 #xBEBF #xBC70 23
      (stage6 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))

    (define (stage6 A-L A-H B-L B-H C-L C-H D-L D-H)
      (wstp A B (fn-H B C D) 13 #x289B #x7EC6  4
      (wstp D A (fn-H A B C)  0 #xEAA1 #x27FA 11
      (wstp C D (fn-H D A B)  3 #xD4EF #x3085 16
      (wstp B C (fn-H C D A)  6 #x0488 #x1D05 23
      (wstp A B (fn-H B C D)  9 #xD9D4 #xD039  4
      (wstp D A (fn-H A B C) 12 #xE6DB #x99E5 11
      (wstp C D (fn-H D A B) 15 #x1FA2 #x7CF8 16
      (wstp B C (fn-H C D A)  2 #xC4AC #x5665 23
      (stage7 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))

    (define (stage7 A-L A-H B-L B-H C-L C-H D-L D-H)
      (wstp A B (fn-I B C D)  0 #xF429 #x2244  6
      (wstp D A (fn-I A B C)  7 #x432A #xFF97 10
      (wstp C D (fn-I D A B) 14 #xAB94 #x23A7 15
      (wstp B C (fn-I C D A)  5 #xFC93 #xA039 21
      (wstp A B (fn-I B C D) 12 #x655B #x59C3  6
      (wstp D A (fn-I A B C)  3 #x8F0C #xCC92 10
      (wstp C D (fn-I D A B) 10 #xFFEF #xF47D 15
      (wstp B C (fn-I C D A)  1 #x8584 #x5DD1 21
      (stage8 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))

    (define (stage8 A-L A-H B-L B-H C-L C-H D-L D-H)
      (wstp A B (fn-I B C D)  8 #x6FA8 #x7E4F  6
      (wstp D A (fn-I A B C) 15 #xFE2C #xE6E0 10
      (wstp C D (fn-I D A B)  6 #xA301 #x4314 15
      (wstp B C (fn-I C D A) 13 #x4E08 #x11A1 21
      (wstp A B (fn-I B C D)  4 #xF753 #x7E82  6
      (wstp D A (fn-I A B C) 11 #xBD3A #xF235 10
      (wstp C D (fn-I D A B)  2 #x2AD7 #xD2BB 15
      (wstp B C (fn-I C D A)  9 #xEB86 #xD391 21
      (stage9 A-L A-H B-L B-H C-L C-H D-L D-H))))))))))

    (define (stage9 A-L A-H B-L B-H C-L C-H D-L D-H)
      (wref AA hash 0 (wadd A AA A (wset hash 0 A)))
      (wref BB hash 1 (wadd B BB B (wset hash 1 B)))
      (wref CC hash 2 (wadd C CC C (wset hash 2 C)))
      (wref DD hash 3 (wadd D DD D (wset hash 3 D))))

    (wref A hash 0
    (wref B hash 1
    (wref C hash 2
    (wref D hash 3
    (stage1 A-L A-H B-L B-H C-L C-H D-L D-H)))))))

(define (open-digest-md5)
  (make-digest
   end-block-digest
   digest-update-block-digest
   (make-block-digest
    digest-update-md5
    (hash-block-init-md5)
    (make-vector 32 0)
    0
    0
    #f
    128)))

;;;----------------------------------------------------------------------------

;; SHA-1 digest.

(define (hash-block-init-sha-1)
  (vector #x2301 #x6745
          #xab89 #xefcd
          #xdcfe #x98ba
          #x5476 #x1032
          #xe1f0 #xc3d2))

(define (digest-update-sha-1 digest)
  (let* ((bd (digest-state digest))
         (hash (block-digest-hash bd))
         (block (block-digest-block bd)))
    (wref OLDA hash 0
    (wref OLDB hash 1
    (wref OLDC hash 2
    (wref OLDD hash 3
    (wref OLDE hash 4
    (let loop ((j 0)
               (A-L OLDA-L) (A-H OLDA-H)
               (B-L OLDB-L) (B-H OLDB-H)
               (C-L OLDC-L) (C-H OLDC-H)
               (D-L OLDD-L) (D-H OLDD-H)
               (E-L OLDE-L) (E-H OLDE-H))

      (define (stage1)
        (if (< j 16)

            (wref T1 block j
            (stage2 T1-L T1-H))

            (wref T1 block (- j 3)
            (wref T2 block (- j 8)
            (wxor T3 T1 T2
            (wref T4 block (- j 14)
            (wxor T5 T3 T4
            (wref T6 block (- j 16)
            (wxor T7 T5 T6
            (wrot X T7 1
            (begin
              (wset block j X)
              (stage2 X-L X-H))))))))))))

      (define (stage2 X-L X-H)
        (cond ((< j 20)
               (wand T1 B C
               (wnot T2 B
               (wand T3 D T2
               (wior T4 T1 T3
               (wlet T5 #x7999 #x5a82
               (wadd T6 T4 T5
               (stage3 X-L X-H T6-L T6-H))))))))
              ((< j 40)
               (wxor T1 B C
               (wxor T2 D T1
               (wlet T3 #xeba1 #x6ed9
               (wadd T4 T2 T3
               (stage3 X-L X-H T4-L T4-H))))))
              ((< j 60)
               (wand T1 B C
               (wand T2 B D
               (wior T3 T1 T2
               (wand T4 C D
               (wior T5 T3 T4
               (wlet T6 #xbcdc #x8f1b
               (wadd T7 T5 T6
               (stage3 X-L X-H T7-L T7-H)))))))))
              (else
               (wxor T1 B C
               (wxor T2 D T1
               (wlet T3 #xc1d6 #xca62
               (wadd T4 T2 T3
               (stage3 X-L X-H T4-L T4-H))))))))

      (define (stage3 X-L X-H Y-L Y-H)
        (wrot T1 A 5
        (wadd T2 E T1
        (wadd T3 X T2
        (wadd T4 Y T3
        (wrot T5 B 30
        (loop (+ j 1)
              T4-L T4-H
              A-L A-H
              T5-L T5-H
              C-L C-H
              D-L D-H)))))))

      (if (< j 80)

          (stage1)

          (begin
            (wadd NEWA A OLDA (wset hash 0 NEWA))
            (wadd NEWB B OLDB (wset hash 1 NEWB))
            (wadd NEWC C OLDC (wset hash 2 NEWC))
            (wadd NEWD D OLDD (wset hash 3 NEWD))
            (wadd NEWE E OLDE (wset hash 4 NEWE))))))))))))

(define (open-digest-sha-1)
  (make-digest
   end-block-digest
   digest-update-block-digest
   (make-block-digest
    digest-update-sha-1
    (hash-block-init-sha-1)
    (make-vector 160 0)
    0
    0
    #t
    160)))

;;;----------------------------------------------------------------------------

;; SHA-224 and SHA-256 digests.

;; The code below is correct, but it is commented out because it
;; triggers some bugs in the Gauche and STklos interpreters.  Gauche
;; accesses the wrong lexical variables in procedure stage4.  STklos
;; gives a bus error probably at macro expansion time.

;;(define (hash-block-init-sha-224)
;;  (vector #x9ed8 #xc105
;;          #xd507 #x367c
;;          #xdd17 #x3070
;;          #x5939 #xf70e
;;          #x0b31 #xffc0
;;          #x1511 #x6858
;;          #x8fa7 #x64f9
;;          #x4fa4 #xbefa))
;;
;;(define (hash-block-init-sha-256)
;;  (vector #xe667 #x6a09
;;          #xae85 #xbb67
;;          #xf372 #x3c6e
;;          #xf53a #xa54f
;;          #x527f #x510e
;;          #x688c #x9b05
;;          #xd9ab #x1f83
;;          #xcd19 #x5be0))
;;
;;(define-macro (fn-W dst i body)
;;  `(wref ,dst block ,i ,body))
;;
;;(define-macro (fn-R dst i body)
;;  `(wref T1 block ,(- i 15) ;; compute S0
;;   (wrot T2 T1 25
;;   (wrot T3 T1 14
;;   (wxor T4 T2 T3
;;   (wshr T5 T1 3
;;   (wxor S0 T4 T5
;;   (wref T6 block ,(- i 2) ;; compute S1
;;   (wrot T7 T6 15
;;   (wrot T8 T6 13
;;   (wxor T9 T7 T8
;;   (wshr T10 T6 10
;;   (wxor S1 T9 T10
;;   (wadd T11 S0 S1 ;; compute sum
;;   (wref T12 block ,(- i 7)
;;   (wadd T13 T11 T12
;;   (wref T14 block ,(- i 16)
;;   (wadd ,dst T13 T14
;;   (begin (wset block ,i ,dst)
;;   ,body)))))))))))))))))))
;;
;;(define-macro (fn-P a b c d e f g h x i k-hi16 k-lo16 body)
;;  `(wrot T1 ,a 30 ;; compute S2
;;   (wrot T2 ,a 19
;;   (wxor T3 T1 T2
;;   (wrot T4 ,a 10
;;   (wxor S2 T3 T4
;;   (wrot T5 ,e 26 ;; compute S3
;;   (wrot T6 ,e 21
;;   (wxor T7 T5 T6
;;   (wrot T8 ,e 7
;;   (wxor S3 T7 T8
;;   (wior T9 ,a ,b ;; compute F0
;;   (wand T10 ,c T9
;;   (wand T11 ,a ,b
;;   (wior F0 T10 T11
;;   (wxor T12 ,f ,g ;; compute F1
;;   (wand T13 ,e T12
;;   (wxor F1 ,g T13
;;   (,x T14 ,i ;; compute (fn-W i) or (fn-R i)
;;   (wadd T15 T14 S3 ;; compute sum
;;   (wadd T16 F1 T15
;;   (wlet T17 ,k-lo16 ,k-hi16
;;   (wadd T18 T16 T17
;;   (wadd T19 ,h T18
;;   (wadd T20 S2 F0
;;   (wadd ,d T19 ,d
;;   (wadd ,h T19 T20
;;   ,body)))))))))))))))))))))))))))
;;
;;(define (digest-update-sha-256 digest)
;;  (let* ((bd (digest-state digest))
;;         (hash (block-digest-hash bd))
;;         (block (block-digest-block bd)))
;;
;;    (define (stage1 A-L A-H B-L B-H C-L C-H D-L D-H
;;                    E-L E-H F-L F-H G-L G-H H-L H-H)
;;      (fn-P A B C D E F G H fn-W  0 #x428A #x2F98
;;      (fn-P H A B C D E F G fn-W  1 #x7137 #x4491
;;      (fn-P G H A B C D E F fn-W  2 #xB5C0 #xFBCF
;;      (fn-P F G H A B C D E fn-W  3 #xE9B5 #xDBA5
;;      (fn-P E F G H A B C D fn-W  4 #x3956 #xC25B
;;      (fn-P D E F G H A B C fn-W  5 #x59F1 #x11F1
;;      (fn-P C D E F G H A B fn-W  6 #x923F #x82A4
;;      (fn-P B C D E F G H A fn-W  7 #xAB1C #x5ED5
;;      (stage2 A-L A-H B-L B-H C-L C-H D-L D-H
;;              E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
;;
;;    (define (stage2 A-L A-H B-L B-H C-L C-H D-L D-H
;;                    E-L E-H F-L F-H G-L G-H H-L H-H)
;;      (fn-P A B C D E F G H fn-W  8 #xD807 #xAA98
;;      (fn-P H A B C D E F G fn-W  9 #x1283 #x5B01
;;      (fn-P G H A B C D E F fn-W 10 #x2431 #x85BE
;;      (fn-P F G H A B C D E fn-W 11 #x550C #x7DC3
;;      (fn-P E F G H A B C D fn-W 12 #x72BE #x5D74
;;      (fn-P D E F G H A B C fn-W 13 #x80DE #xB1FE
;;      (fn-P C D E F G H A B fn-W 14 #x9BDC #x06A7
;;      (fn-P B C D E F G H A fn-W 15 #xC19B #xF174
;;      (stage3 A-L A-H B-L B-H C-L C-H D-L D-H
;;              E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
;;
;;    (define (stage3 A-L A-H B-L B-H C-L C-H D-L D-H
;;                    E-L E-H F-L F-H G-L G-H H-L H-H)
;;      (fn-P A B C D E F G H fn-R 16 #xE49B #x69C1
;;      (fn-P H A B C D E F G fn-R 17 #xEFBE #x4786
;;      (fn-P G H A B C D E F fn-R 18 #x0FC1 #x9DC6
;;      (fn-P F G H A B C D E fn-R 19 #x240C #xA1CC
;;      (fn-P E F G H A B C D fn-R 20 #x2DE9 #x2C6F
;;      (fn-P D E F G H A B C fn-R 21 #x4A74 #x84AA
;;      (fn-P C D E F G H A B fn-R 22 #x5CB0 #xA9DC
;;      (fn-P B C D E F G H A fn-R 23 #x76F9 #x88DA
;;      (stage4 A-L A-H B-L B-H C-L C-H D-L D-H
;;              E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
;;
;;    (define (stage4 A-L A-H B-L B-H C-L C-H D-L D-H
;;                    E-L E-H F-L F-H G-L G-H H-L H-H)
;;      (fn-P A B C D E F G H fn-R 24 #x983E #x5152
;;      (fn-P H A B C D E F G fn-R 25 #xA831 #xC66D
;;      (fn-P G H A B C D E F fn-R 26 #xB003 #x27C8
;;      (fn-P F G H A B C D E fn-R 27 #xBF59 #x7FC7
;;      (fn-P E F G H A B C D fn-R 28 #xC6E0 #x0BF3
;;      (fn-P D E F G H A B C fn-R 29 #xD5A7 #x9147
;;      (fn-P C D E F G H A B fn-R 30 #x06CA #x6351
;;      (fn-P B C D E F G H A fn-R 31 #x1429 #x2967
;;      (stage5 A-L A-H B-L B-H C-L C-H D-L D-H
;;              E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
;;
;;    (define (stage5 A-L A-H B-L B-H C-L C-H D-L D-H
;;                    E-L E-H F-L F-H G-L G-H H-L H-H)
;;      (fn-P A B C D E F G H fn-R 32 #x27B7 #x0A85
;;      (fn-P H A B C D E F G fn-R 33 #x2E1B #x2138
;;      (fn-P G H A B C D E F fn-R 34 #x4D2C #x6DFC
;;      (fn-P F G H A B C D E fn-R 35 #x5338 #x0D13
;;      (fn-P E F G H A B C D fn-R 36 #x650A #x7354
;;      (fn-P D E F G H A B C fn-R 37 #x766A #x0ABB
;;      (fn-P C D E F G H A B fn-R 38 #x81C2 #xC92E
;;      (fn-P B C D E F G H A fn-R 39 #x9272 #x2C85
;;      (stage6 A-L A-H B-L B-H C-L C-H D-L D-H
;;              E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
;;
;;    (define (stage6 A-L A-H B-L B-H C-L C-H D-L D-H
;;                    E-L E-H F-L F-H G-L G-H H-L H-H)
;;      (fn-P A B C D E F G H fn-R 40 #xA2BF #xE8A1
;;      (fn-P H A B C D E F G fn-R 41 #xA81A #x664B
;;      (fn-P G H A B C D E F fn-R 42 #xC24B #x8B70
;;      (fn-P F G H A B C D E fn-R 43 #xC76C #x51A3
;;      (fn-P E F G H A B C D fn-R 44 #xD192 #xE819
;;      (fn-P D E F G H A B C fn-R 45 #xD699 #x0624
;;      (fn-P C D E F G H A B fn-R 46 #xF40E #x3585
;;      (fn-P B C D E F G H A fn-R 47 #x106A #xA070
;;      (stage7 A-L A-H B-L B-H C-L C-H D-L D-H
;;              E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
;;
;;    (define (stage7 A-L A-H B-L B-H C-L C-H D-L D-H
;;                    E-L E-H F-L F-H G-L G-H H-L H-H)
;;      (fn-P A B C D E F G H fn-R 48 #x19A4 #xC116
;;      (fn-P H A B C D E F G fn-R 49 #x1E37 #x6C08
;;      (fn-P G H A B C D E F fn-R 50 #x2748 #x774C
;;      (fn-P F G H A B C D E fn-R 51 #x34B0 #xBCB5
;;      (fn-P E F G H A B C D fn-R 52 #x391C #x0CB3
;;      (fn-P D E F G H A B C fn-R 53 #x4ED8 #xAA4A
;;      (fn-P C D E F G H A B fn-R 54 #x5B9C #xCA4F
;;      (fn-P B C D E F G H A fn-R 55 #x682E #x6FF3
;;      (stage8 A-L A-H B-L B-H C-L C-H D-L D-H
;;              E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
;;
;;    (define (stage8 A-L A-H B-L B-H C-L C-H D-L D-H
;;                    E-L E-H F-L F-H G-L G-H H-L H-H)
;;      (fn-P A B C D E F G H fn-R 56 #x748F #x82EE
;;      (fn-P H A B C D E F G fn-R 57 #x78A5 #x636F
;;      (fn-P G H A B C D E F fn-R 58 #x84C8 #x7814
;;      (fn-P F G H A B C D E fn-R 59 #x8CC7 #x0208
;;      (fn-P E F G H A B C D fn-R 60 #x90BE #xFFFA
;;      (fn-P D E F G H A B C fn-R 61 #xA450 #x6CEB
;;      (fn-P C D E F G H A B fn-R 62 #xBEF9 #xA3F7
;;      (fn-P B C D E F G H A fn-R 63 #xC671 #x78F2
;;      (stage9 A-L A-H B-L B-H C-L C-H D-L D-H
;;              E-L E-H F-L F-H G-L G-H H-L H-H))))))))))
;;
;;    (define (stage9 A-L A-H B-L B-H C-L C-H D-L D-H
;;                    E-L E-H F-L F-H G-L G-H H-L H-H)
;;      (wref OLDA hash 0 (wadd NEWA A OLDA (wset hash 0 NEWA)))
;;      (wref OLDB hash 1 (wadd NEWB B OLDB (wset hash 1 NEWB)))
;;      (wref OLDC hash 2 (wadd NEWC C OLDC (wset hash 2 NEWC)))
;;      (wref OLDD hash 3 (wadd NEWD D OLDD (wset hash 3 NEWD)))
;;      (wref OLDE hash 4 (wadd NEWE E OLDE (wset hash 4 NEWE)))
;;      (wref OLDF hash 5 (wadd NEWF F OLDF (wset hash 5 NEWF)))
;;      (wref OLDG hash 6 (wadd NEWG G OLDG (wset hash 6 NEWG)))
;;      (wref OLDH hash 7 (wadd NEWH H OLDH (wset hash 7 NEWH))))
;;
;;    (wref A hash 0
;;    (wref B hash 1
;;    (wref C hash 2
;;    (wref D hash 3
;;    (wref E hash 4
;;    (wref F hash 5
;;    (wref G hash 6
;;    (wref H hash 7
;;    (stage1 A-L A-H B-L B-H C-L C-H D-L D-H
;;            E-L E-H F-L F-H G-L G-H H-L H-H)))))))))))
;;
;;(define (open-digest-sha-224)
;;  (make-digest
;;   end-block-digest
;;   digest-update-block-digest
;;   (make-block-digest
;;    digest-update-sha-256
;;    (hash-block-init-sha-224)
;;    (make-vector 160 0)
;;    0
;;    0
;;    #t
;;    224)))
;;
;;(define (open-digest-sha-256)
;;  (make-digest
;;   end-block-digest
;;   digest-update-block-digest
;;   (make-block-digest
;;    digest-update-sha-256
;;    (hash-block-init-sha-256)
;;    (make-vector 160 0)
;;    0
;;    0
;;    #t
;;    256)))

;;;----------------------------------------------------------------------------

(define (open-digest algorithm)

  ;; Dispatch on algorithm (can't use a "case" special form because on
  ;; case-insensitive systems this would cause duplicate cases).

  (cond ((memq algorithm '(crc32 CRC32))
         (open-digest-crc32))
        ((memq algorithm '(md5 MD5))
         (open-digest-md5))
        ((memq algorithm '(sha-1 SHA-1))
         (open-digest-sha-1))
;;        ((memq algorithm '(sha-224 SHA-224))
;;         (open-digest-sha-224))
;;        ((memq algorithm '(sha-256 SHA-256))
;;         (open-digest-sha-256))
;;        ((memq algorithm '(sha-384 SHA-384))
;;         (open-digest-sha-384))
;;        ((memq algorithm '(sha-512 SHA-512))
;;         (open-digest-sha-512))
        (else
         (snow-error "unknown hashing algorithm" algorithm))))

(define-macro (digest-default-result-type) ''hex)

(define* (close-digest
          digest
          (result-type (digest-default-result-type)))
  ((digest-end digest) digest result-type))

(define (digest-update-subu8vector digest u8vect start end)
  ((digest-update digest) digest u8vect start end))

(define zero-u8vector (snow-make-u8vector 4 0))

(define (get-zero-u8vector) zero-u8vector)

(define (digest-update-u8 digest n) ;; assumes n is a fixnum
  (digest-update-subu8vector
   digest
   (if (eqv? n 0)
       (get-zero-u8vector)
       (snow-make-u8vector 1 (snow-fxand n #xff)))
   0
   1))

(define (digest-update-u16-le digest n) ;; assumes n is a fixnum
  (digest-update-subu8vector
   digest
   (if (eqv? n 0)
       (get-zero-u8vector)
       (let ((u8vect (snow-make-u8vector 2)))
         (snow-u8vector-set!
          u8vect
          0
          (snow-fxand n #xff))
         (snow-u8vector-set!
          u8vect
          1
          (snow-fxand (snow-fxarithmetic-shift-right n 8) #xff))
         u8vect))
   0
   2))

(define (digest-update-u16-be digest n) ;; assumes n is a fixnum
  (digest-update-subu8vector
   digest
   (if (eqv? n 0)
       (get-zero-u8vector)
       (let ((u8vect (snow-make-u8vector 2)))
         (snow-u8vector-set!
          u8vect
          1
          (snow-fxand n #xff))
         (snow-u8vector-set!
          u8vect
          0
          (snow-fxand (snow-fxarithmetic-shift-right n 8) #xff))
         u8vect))
   0
   2))

(define (digest-update-u32-le digest n) ;; assumes n is a fixnum
  (digest-update-subu8vector
   digest
   (if (eqv? n 0)
       (get-zero-u8vector)
       (let ((u8vect (snow-make-u8vector 4)))
         (snow-u8vector-set!
          u8vect
          0
          (snow-fxand n #xff))
         (snow-u8vector-set!
          u8vect
          1
          (snow-fxand (snow-fxarithmetic-shift-right n 8) #xff))
         (snow-u8vector-set!
          u8vect
          2
          (snow-fxand (snow-fxarithmetic-shift-right n 16) #xff))
         (snow-u8vector-set!
          u8vect
          3
          (snow-fxand (snow-fxarithmetic-shift-right n 24) #xff))
         u8vect))
   0
   4))

(define (digest-update-u32-be digest n) ;; assumes n is a fixnum
  (digest-update-subu8vector
   digest
   (if (eqv? n 0)
       (get-zero-u8vector)
       (let ((u8vect (snow-make-u8vector 4)))
         (snow-u8vector-set!
          u8vect
          3
          (snow-fxand n #xff))
         (snow-u8vector-set!
          u8vect
          2
          (snow-fxand (snow-fxarithmetic-shift-right n 8) #xff))
         (snow-u8vector-set!
          u8vect
          1
          (snow-fxand (snow-fxarithmetic-shift-right n 16) #xff))
         (snow-u8vector-set!
          u8vect
          0
          (snow-fxand (snow-fxarithmetic-shift-right n 24) #xff))
         u8vect))
   0
   4))

(define* (digest-string
          str
          algorithm
          (result-type (digest-default-result-type)))
  (digest-substring
   str
   0
   (string-length str)
   algorithm
   result-type))

(define* (digest-substring
          str
          start
          end
          algorithm
          (result-type (digest-default-result-type)))
  (let* ((len (- end start))
         (u8vect (snow-make-u8vector len)))
    (let loop ((i 0))
      (if (< i len)
          (begin
            (snow-u8vector-set! u8vect i (char->integer (string-ref str i)))
            (loop (+ i 1)))
          (digest-subu8vector u8vect 0 len algorithm result-type)))))

(define* (digest-u8vector
          u8vect
          algorithm
          (result-type (digest-default-result-type)))
  (digest-subu8vector
   u8vect
   0
   (snow-u8vector-length u8vect)
   algorithm
   result-type))

(define* (digest-subu8vector
          u8vect
          start
          end
          algorithm
          (result-type (digest-default-result-type)))
  (let ((digest (open-digest algorithm)))
    (digest-update-subu8vector digest u8vect start end)
    (close-digest digest result-type)))

(define* (digest-file
          filename
          algorithm
          (result-type (digest-default-result-type)))
  (let ((digest (open-digest algorithm)))
    (let* ((in (binio-open-input-file filename))
           (bufsize 1024)
           (buf (snow-make-u8vector bufsize)))
      (let loop ()
        (let ((n (binio-read-subu8vector buf 0 bufsize in)))
          (if (= n 0)
              (begin
                (binio-close-input-port in)
                (close-digest digest result-type))
              (begin
                (digest-update-subu8vector digest buf 0 n)
                (loop))))))))

;;;----------------------------------------------------------------------------

;; Self tests.

(test*

 (define crc32-test-vectors
   '(
     ("" 0 ""
      "00000000")
     ("" 0 "a"
      "e8b7be43")
     ("" 0 "abc"
      "352441c2")
     ("" 0 "abcdefghijklmnopqrstuvwxyz"
      "4c2750bd")
     ("" 0 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
      "1fc2e6d2")
     ("" 0 "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
      "7ca94a72")
     ))

 (define md5-test-vectors
   '(
     ;; from RFC 1321:
     ("" 0 ""
      "d41d8cd98f00b204e9800998ecf8427e")
     ("" 0 "a"
      "0cc175b9c0f1b6a831c399e269772661")
     ("" 0 "abc"
      "900150983cd24fb0d6963f7d28e17f72")
     ("" 0 "message digest"
      "f96b697d7cb7938d525a2f31aaf161d0")
     ("" 0 "abcdefghijklmnopqrstuvwxyz"
      "c3fcd3d76192e4007dfb496cca67e13b")
     ("" 0 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
      "d174ab98d277d9f5a5611c2c9f419d9f")
     ("" 0 "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
      "57edf4a22be3c955ac49da2e2107b67a")
     ))

 (define sha-1-test-vectors
   '(
     ("" 0 ""
      "da39a3ee5e6b4b0d3255bfef95601890afd80709")
     ;; from RFC 3174:
     ("" 0 "abc"
      "a9993e364706816aba3e25717850c26c9cd0d89d")
     ("" 0 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
      "84983e441c3bd26ebaae4aa1f95129e5e54670f1")
;;     ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" 10000 ""
;;      "34aa973cd4c4daa4f61eeb2bdbad27316534016f")
     ("0123456701234567012345670123456701234567012345670123456701234567" 10 ""
      "dea356a2cddd90c7a7ecedc5ebb563934f460452")
     ))

 (define sha-224-test-vectors
   '(
     ;; from RFC 3874:
     ("" 0 "abc"
      "23097d223405d8228642a477bda255b32aadbce4bda0b3f7e36c9da7")
     ("" 0 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
      "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525")
;;     ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" 10000 ""
;;      "20794655980c91d8bbb4c1ea97618a4bf03f42581948b2ee4ee7ad67")
    ))

 (define sha-256-test-vectors
   '(
     ("" 0 ""
      "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855")
     ;; from FIPS-180-2:
     ("" 0 "abc"
      "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad")
     ("" 0 "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
      "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1")
;;     ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" 10000 ""
;;      "cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0")
    ))

 (define (test-digest)

   (define (t algorithm vectors)
     (for-each
      (lambda (v)
        (let ((str1 (car v))
              (repeat (cadr v))
              (str2 (caddr v))
              (expect (cadddr v)))
          (let ((md
                 (if (= repeat 0)
                     (digest-string str2 algorithm 'hex)
                     (let ((u8vect1
                            (snow-list->u8vector
                             (map char->integer (string->list str1))))
                           (u8vect2
                            (snow-list->u8vector
                             (map char->integer (string->list str2))))
                           (digest
                            (open-digest algorithm)))
                       (let loop ((i 0))
                         (if (< i repeat)
                             (begin
                               (digest-update-subu8vector
                                digest
                                u8vect1
                                0
                                (snow-u8vector-length u8vect1))
                               (loop (+ i 1)))
                             (begin
                               (digest-update-subu8vector
                                digest
                                u8vect2
                                0
                                (snow-u8vector-length u8vect2))
                               (close-digest digest 'hex))))))))
            (expect* (string-ci=? md expect)))))
      vectors))

   (t 'crc32 crc32-test-vectors)
   (t 'md5 md5-test-vectors)
   (t 'sha-1 sha-1-test-vectors)
;;   (t 'sha-224 sha-224-test-vectors)
;;   (t 'sha-256 sha-256-test-vectors)
)

 (test-digest))

;;;============================================================================