source: project/release/4/message-digest/trunk/message-digest-support.scm @ 35044

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

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

(use
  (only lolevel number-of-bytes)
  (only srfi-4
    s8vector?
    u8vector?
    s16vector?
    u16vector?
    s32vector?
    u32vector?
    #;u64vector?
    #;u64vector?
    f32vector?
    f64vector?
    u8vector->blob/shared
    s8vector->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
    subu8vector u8vector-length)
  message-digest-primitive
  message-digest-type
  fx-utils)

;;; Support

;;

;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 (fxzero? start) (fx= end (u8vector-length u8vec)))
      u8vec
      (subu8vector u8vec start end) ) ) )

(define (blob/slice blb start end)
  (let ((end (or end (blob-size blb))))
    (if (and (fxzero? start) (fx= end (blob-size blb)))
      blb
      (string->blob (##sys#substring (blob->string blb) start end)) ) ) )

(define (string/slice str start end)
  (let ((end (or end (string-length str))))
    (if (and (fxzero? start) (fx= end (string-length str)))
      str
      (##sys#substring str start end) ) ) )

;;

(define (*message-digest-update-blob md blb #!optional (siz (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