;;;; blob-utils.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Apr '12

;; Issues
;;
;; - Chicken uses "signed integer" but treated here as "unsigned integer"

(module blob-utils

(;export
  bytes->hexstring
  bytes-set-u8! bytes-set-s8!
  bytes-set-u16! bytes-set-s16!
  bytes-set-u32! bytes-set-s32!
  bytes-set-u64! bytes-set-s64!)

(import scheme
  (chicken base)
  (chicken blob)
  (chicken platform)
  (chicken type)
  (srfi 4)
  (only type-errors error-argument-type)
  blob-hexadecimal
  blob-set-int)

;;; Bytevector - Blob, String, & SRFI-4-Vector

(define-type srfi-4-uint-vector (or u8vector u16vector u32vector))
(define-type srfi-4-int-vector (or s8vector s16vector s32vector))
(define-type srfi-4-float-vector (or f32vector f64vector))
(define-type srfi-4-vector (or srfi-4-uint-vector srfi-4-int-vector srfi-4-float-vector))

(define-type bytevector (or blob string srfi-4-vector))

;;

(define-inline (get-bv-alias loc obj)
  (cond
    ((blob? obj)
      obj )
    ((string? obj)
      obj )
    ((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) )
    ((f32vector? obj)
      (f32vector->blob/shared obj) )
    ((f64vector? obj)
      (f64vector->blob/shared obj) )
    (else
    	(error-argument-type loc obj "blob, string, or srfi-4-vector" obj) ) ) )

(define-inline (get-bv loc obj)
  (if (string? obj)
    (string->blob obj)
    (get-bv-alias loc obj) ) )

;;

(: bytes->hexstring (bytevector #!optional fixnum fixnum -> string))
;
(define (bytes->hexstring bv #!optional (start 0) (end #f))
  (blob->hex (get-bv 'bytes->hexstring bv) start end) )

;; 8

(: bytes-set-u8! (bytevector fixnum fixnum -> void))
;
(define (bytes-set-u8! bv idx uint)
	(*blob-set-u8! (get-bv-alias 'bytes-set-u8! bv) uint idx) )

(: bytes-set-s8! (bytevector fixnum fixnum -> void))
;
(define (bytes-set-s8! bv idx int)
	(*blob-set-u8! (get-bv-alias 'bytes-set-u8! bv) int idx) )

;; Both Endian 16, 32, & 64

(define-inline (get-byte-order loc obj)
  (case obj
  	((big-endian be big msb)
  	  'big-endian )
  	((little-endian le little lsb)
  	  'little-endian )
    (else
    	(error-argument-type loc obj "symbol in {big-endian be big msb little-endian le little lsb}" obj) ) ) )

;;

(: bytes-set-u16! (bytevector fixnum fixnum -> void))
;
(define (bytes-set-u16! bv idx uint #!optional (order (machine-byte-order)))
	(let ((bv (get-bv-alias 'bytes-set-u16! bv)))
		(case (get-byte-order 'bytes-set-u16! order)
			((little-endian)
			  (*blob-set-u16-le! bv uint idx) )
			((big-endian)
			  (*blob-set-u16-be! bv uint idx) ) ) ) )

(: bytes-set-s16! (bytevector fixnum fixnum -> void))
;
(define (bytes-set-s16! bv idx int #!optional (order (machine-byte-order)))
	(let ((bv (get-bv-alias 'bytes-set-s16! bv)))
		(case (get-byte-order 'bytes-set-s16! order)
			((little-endian)
			  (*blob-set-u16-le! bv int idx) )
			((big-endian)
			  (*blob-set-u16-be! bv int idx) ) ) ) )


(: bytes-set-u32! (bytevector fixnum number -> void))
;
(define (bytes-set-u32! bv idx uint #!optional (order (machine-byte-order)))
	(let ((bv (get-bv-alias 'bytes-set-u32! bv)))
		(case (get-byte-order 'bytes-set-u32! order)
			((little-endian)
			  (*blob-set-u32-le! bv uint idx) )
			((big-endian)
			  (*blob-set-u32-be! bv uint idx) ) ) ) )

(: bytes-set-s32! (bytevector fixnum number -> void))
;
(define (bytes-set-s32! bv idx int #!optional (order (machine-byte-order)))
	(let ((bv (get-bv-alias 'bytes-set-s32! bv)))
		(case (get-byte-order 'bytes-set-s32! order)
			((little-endian)
			  (*blob-set-u32-le! bv int idx) )
			((big-endian)
			  (*blob-set-u32-be! bv int idx) ) ) ) )

(: bytes-set-u64! (bytevector fixnum number -> void))
;
(define (bytes-set-u64! bv idx uint #!optional (order (machine-byte-order)))
	(let ((bv (get-bv-alias 'bytes-set-u64! bv)))
		(case (get-byte-order 'bytes-set-u64! order)
			((little-endian)
			  (*blob-set-u64-le! bv uint idx) )
			((big-endian)
			  (*blob-set-u64-be! bv uint idx) ) ) ) )

(: bytes-set-s64! (bytevector fixnum number -> void))
;
(define (bytes-set-s64! bv idx int #!optional (order (machine-byte-order)))
	(let ((bv (get-bv-alias 'bytes-set-s64! bv)))
		(case (get-byte-order 'bytes-set-s64! order)
			((little-endian)
			  (*blob-set-u64-le! bv int idx) )
			((big-endian)
			  (*blob-set-u64-be! bv int idx) ) ) ) )

) ;module blob-utils