;;;; message-digest-support.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Aug '17
;;;; Kon Lovett, Apr '12
;;;; Kon Lovett, May '10 (message-digest.scm)
;;;; Kon Lovett, Jan '06 (message-digest.scm)

;; Issues
;;
;; - blob has byte index but string has character index!
;;
;; - Uses 'context-info' to determine whether active context is "own" allocation or
;; callers. Again, a kludge.
;;
;; - Passes u8vector to update phase as a blob.

(module message-digest-support

(;export
  ;Support
  packed-vector->blob/shared
  ;
  u8vector/slice blob/slice string/slice
  ;
  *message-digest-update-blob
  *message-digest-update-string)

(import scheme)
(import (chicken base))
(import (chicken blob))
(import (chicken type))
(import (only (chicken memory representation) number-of-bytes))
(import (only (chicken memory) move-memory!))
(import (only srfi-4
  s8vector? u8vector? subu8vector u8vector-length
  s16vector? u16vector?
  s32vector? u32vector?
  u64vector? s64vector?
  f32vector? f64vector?
  s8vector->blob/shared u8vector->blob/shared
  s16vector->blob/shared u16vector->blob/shared
  s32vector->blob/shared u32vector->blob/shared
  s64vector->blob/shared u64vector->blob/shared
  f32vector->blob/shared f64vector->blob/shared))
(import message-digest-primitive)
(import message-digest-type)

(include-relative "message-digest.types")

(define-type start-index fixnum)
(define-type end-index (or false fixnum))

(: packed-vector->blob/shared (srfi-4-vector -> (or false blob)))
(: u8vector/slice (u8vector start-index end-index -> u8vector))
(: blob/slice (blob start-index end-index -> blob))
(: string/slice (string start-index end-index -> string))

(: message-digest-algorithm-update (message-digest -> procedure))

(: *message-digest-update-blob (message-digest blob #!optional fixnum -> void))
(: *message-digest-update-string (message-digest string #!optional fixnum -> void))

;;

;Used by update-item & srfi-4 modules

(define (packed-vector->blob/shared obj)
  (cond ((u8vector? obj) (u8vector->blob/shared obj))
        ((s8vector? obj) (s8vector->blob/shared obj))
        ((u16vector? obj) (u16vector->blob/shared obj))
        ((s16vector? obj) (s16vector->blob/shared obj))
        ((u32vector? obj) (u32vector->blob/shared obj))
        ((s32vector? obj) (s32vector->blob/shared obj))
        ((u64vector? obj) (u64vector->blob/shared obj))
        ((s64vector? obj) (s64vector->blob/shared obj))
        ((f32vector? obj) (f32vector->blob/shared obj))
        ((f64vector? obj) (f64vector->blob/shared obj))
        (else #f ) ) )

;;

(define (subblob blb start end)
  (let* ((siz (- end start))
         (buf (make-blob siz)) )
    (move-memory! blb buf siz start 0)
    buf ) )

(define string-size number-of-bytes)

;;

(define (u8vector/slice u8vec start end)
  (let ((end (or end (u8vector-length u8vec))))
    (if (and (= end (u8vector-length u8vec)) (zero? start))
        u8vec
        (subu8vector u8vec start end) ) ) )

(define (blob/slice blb start end)
  (let ((end (or end (blob-size blb))))
    (if (and (= end (blob-size blb)) (zero? start))
        blb
        (subblob blb start end)) ) )

(define (string/slice str start end)
  (let ((end (or end (string-length str))))
    (if (and (= end (string-length str)) (zero? start))
        str
        (substring str start end) ) ) )

;;

(define (message-digest-algorithm-update md)
  (message-digest-primitive-update (message-digest-algorithm md)) )

;;

(define (*message-digest-update-blob md blb . opts)
  (let ((siz (optional opts (blob-size blb))))
    ((message-digest-algorithm-update md) (message-digest-context md) blb siz) ) )

(define (*message-digest-update-string md str . opts)
  (let ((siz (optional opts (string-size str))))
    ((message-digest-algorithm-update md) (message-digest-context md) str siz) ) )

) ;module message-digest-support