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

;; Issues

#>
/* start is not a general offset. bytes length <= size */
static void
pack_uint64( uint8_t *bytes, uint64_t n, int size, int direction, int start )
{
  int end;

  if(size == 1) {                           /* 1 byte */
    bytes[start] = n;
  } else if(direction == -1) {           /* Big endian */
    end = start;
    bytes[start += size - 1] = n & 0xff;    /* 2 bytes */
    bytes[--start] = (n >> 8) & 0xff;
    if(start != end) {                      /* 4 bytes */
      bytes[--start] = (n >> 16) & 0xff;
      bytes[--start] = (n >> 24) & 0xff;
      if(start != end) {                    /* 8 bytes */
        bytes[--start] = (n >> 32) & 0xff;
        bytes[--start] = (n >> 40) & 0xff;
        bytes[--start] = (n >> 48) & 0xff;
        bytes[--start] = (n >> 56) & 0xff;
      }
    }
  } else {                              /* Little endian */
    end = start + size - 1;
    bytes[start] = n & 0xff;              /* 2 bytes */
    bytes[++start] = (n >> 8) & 0xff;
    if(start != end) {                    /* 4 bytes */
      bytes[++start] = (n >> 16) & 0xff;
      bytes[++start] = (n >> 24) & 0xff;
      if(start != end) {                  /* 8 bytes */
        bytes[++start] = (n >> 32) & 0xff;
        bytes[++start] = (n >> 40) & 0xff;
        bytes[++start] = (n >> 48) & 0xff;
        bytes[++start] = (n >> 56) & 0xff;
      }
    }
  }
}
<#

(module pack-integer

(;export
  pack-u8
  pack-u16
  pack-u32
  pack-u64
  pack-integer)

(import scheme
  (chicken base)
  (chicken fixnum)
  (chicken blob)
  (chicken platform)
  (chicken foreign)
  (chicken type)
  (only (chicken memory representation) number-of-bytes)
  (only (srfi 4)
    make-u8vector u8vector? u8vector-length u8vector-set!)
  (only type-checks
    check-blob check-integer check-natural-fixnum
    define-check+error-type)
  (only type-errors
    error-argument-type
    error-half-closed-interval
    define-error-type)
  blob-set-int)

;;;

(define (fxzero? x)
  (fx= 0 x) )

;;; Integer Packing Utilities

;;

; All the below primitive pack routines must return the supplied buffer object.

;; Pack an 8 bit integer

(define-inline (pack-u8-with-u8vector! u8vec n i)
  (u8vector-set! u8vec i n)
  u8vec )

(define-inline (pack-u8-with-bytevector! bv n i)
  (##core#inline "C_setbyte" bv i n) ;(bytevector-set! bv i n)
  bv )

(define-inline (pack-u8-with-blob! blb n i)
  (pack-u8-with-bytevector! blb n i) )

(define-inline (pack-u8-with-string! str n i)
  (pack-u8-with-bytevector! str n i) )

; Pack a 16, 32, or 64 bit integer with endian order

(define-inline (pack-u64-with-u8vector! u8vec n size direction start)
  ((foreign-lambda void "pack_uint64" nonnull-u8vector unsigned-integer64 int int int)
     u8vec n size direction start)
  u8vec )

(define-inline (pack-u64-with-bytevector! bv n size direction start)
  ((foreign-lambda void "pack_uint64" nonnull-scheme-pointer unsigned-integer64 int int int)
    bv n size direction start)
  bv )

(define-inline (pack-u64-with-blob! blb n size direction start)
  (pack-u64-with-bytevector! blb n size direction start) )

(define-inline (pack-u64-with-string! str n size direction start)
  (pack-u64-with-bytevector! str n size direction start) )

;;

(define-constant MAX-BV-LEN 16777215) ;2^24-1 is the maximum length of a bytevector

(define-inline (byte-order->direction order)
  (case order
    ((big-endian be big)
      -1 )
    ((little-endian le little)
      1 )
    (else
      0 ) ) )

(define-inline (check-byte-size loc obj)
  (unless (memq obj '(1 2 4 8))
    (error-argument-type loc obj "integer in {1 2 4 8}" 'size) )
  obj )

(define-inline (check-byte-buffer-size loc dessiz actsiz)
  (unless (fx<= dessiz actsiz)
    ;FIXME this message is too strong
    (error-half-closed-interval loc actsiz dessiz MAX-BV-LEN "byte-buffer size+start") )
  actsiz )

(define-type byte-order symbol)

(: byte-order? (* -> boolean : byte-order))
;
(define (byte-order? obj)
  (not (fxzero? (byte-order->direction obj))) )

(define-check+error-type byte-order byte-order? "symbol in {big-endian be big little-endian le little}")

(define-type buffer-type (or string blob u8vector))

(define-error-type byte-buffer-kind "symbol in {u8vector blob string}")
(define-error-type byte-buffer "u8vector, blob, string")

(: ensure-byte-buffer (symbol fixnum (or symbol buffer-type) fixnum -> symbol buffer-type))
;
(define (ensure-byte-buffer loc size kind start)
  (check-natural-fixnum loc size 'size)
  (check-natural-fixnum loc start 'start)
  (let (
    (buffer-size (fx+ start size)) )
    ;cases ordered by a guess of probability
    (cond
      ((symbol? kind)
        (case kind
          ((string)
            (values 'string (make-string buffer-size)) )
          ((blob)
            (values 'blob (make-blob buffer-size)) )
          ((u8vector)
            (values 'u8vector (make-u8vector buffer-size)) )
          (else
            (error-byte-buffer-kind loc kind) ) ) )
      ((string? kind)
        (check-byte-buffer-size loc buffer-size (number-of-bytes kind))
        (values 'string kind) )
      ((blob? kind)
        (check-byte-buffer-size loc buffer-size (number-of-bytes kind))
        (values 'blob kind) )
      ((u8vector? kind)
        (check-byte-buffer-size loc buffer-size (u8vector-length kind))
        (values 'u8vector kind) )
      (else
        (error-byte-buffer loc kind) ) ) ) )

;;

(: *pack-u8 (symbol fixnum (or symbol buffer-type) fixnum -> buffer-type))
;
(define (*pack-u8 loc n kind start)
  (check-integer loc n)
  (let-values (
    ((knd obj) (ensure-byte-buffer loc 1 kind start)) )
    (case knd
      ((string)
        (pack-u8-with-string! obj n start) )
      ((blob)
        (pack-u8-with-blob! obj n start) )
      ((u8vector)
        (pack-u8-with-u8vector! obj n start) ) )
    obj ) )

(: pack-u8 (fixnum #!rest -> buffer-type))
;
(define (pack-u8 n #!key (kind 'string) (start 0))
  (*pack-u8 'pack-u8 n kind start) )

;;

(: *pack-integer (symbol number (or symbol buffer-type) fixnum symbol fixnum -> buffer-type))
;
(define (*pack-integer loc n kind size order start)
  (check-integer loc n)
  (check-byte-order loc order)
  (let-values (
    ((knd obj) (ensure-byte-buffer loc size kind start)) )
    (let (
      (direction (byte-order->direction order)) )
      (case knd
        ((string)
          (pack-u64-with-string! obj n size direction start) )
        ((blob)
          (pack-u64-with-blob! obj n size direction start) )
        ((u8vector)
          (pack-u64-with-u8vector! obj n size direction start) ) ) )
    obj ) )

;;

(: pack-u16 (fixnum #!rest -> buffer-type))
;
(define (pack-u16 n #!key (kind 'string) (start 0) (order (machine-byte-order)))
  (*pack-integer 'pack-u16 n kind 2 order start) )

;;

(: pack-u32 (number #!rest -> buffer-type))
;
(define (pack-u32 n #!key (kind 'string) (start 0) (order (machine-byte-order)))
  (*pack-integer 'pack-u32 n kind 4 order start) )

;;

(: pack-u64 (number #!rest -> buffer-type))
;
(define (pack-u64 n #!key (kind 'string) (start 0) (order (machine-byte-order)))
  (*pack-integer 'pack-u64 n kind 8 order start) )

;;

(: pack-integer (number #!rest -> buffer-type))
;
(define (pack-integer n #!key (kind 'string) (start 0) (order (machine-byte-order)) (size 4))
  (check-byte-size 'pack-integer size)
  (if (fx= 1 size)
    (let-values (
      ((knd obj) (ensure-byte-buffer 'pack-integer size kind start)) )
      (*blob-set-u8! n obj start) )
    (*pack-integer 'pack-integer n kind size order start) ) )

) ;module pack-integer