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

;; Support

;;

(include "message-digest.types")

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

(: packed-vector->blob/shared (srfi4vector -> (or boolean 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-update-blob (message-digest blob #!rest -> void))
(: *message-digest-update-string (message-digest string -> void))
(: message-digest-algorithm-update (message-digest -> procedure))

;;

;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 (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
  ;need byte-oriented semantics
  (let ((substring substring))
    (lambda (blb start end)
      (let (
        (end (or end (blob-size blb))) )
        (if (and (= end (blob-size blb)) (zero? start))
          blb
          (string->blob (substring (blob->string 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-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)
	(*message-digest-update-blob md (string->blob str)) )

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

) ;module message-digest-support