;;;; binary.io -- serializing binary data

;;; Created:    <2003-01-20 23:25:06 foof>
;;; Time-stamp: <2003-01-29 20:53:45 foof>
;;; Author:     Alex Shinn <foof@synthcode.com>

;; It is computed that eleven thousand persons have at several times
;; suffered death, rather than submit to break their eggs at the smaller
;; end.  Many hundred large volumes have been published upon this
;; controversy: but the books of the Big-endians have been long
;; forbidden, and the whole party rendered incapable by law of holding
;; employments.
;;          -- from "Gulliver's Travels" by Jonathan Swift

;; [SK]: 
;;

;; $Id: io.scm,v 1.5 2007/02/20 08:43:19 shirok Exp $

(define-module binary.io
  (use gauche.uvector)
  (use srfi-1)  ;; list library
  (use srfi-13) ;; string library
  (export default-endian
          read-uint read-u8 read-u16 read-u32 read-u64
          read-sint read-s8 read-s16 read-s32 read-s64
          read-ber-integer read-f16 read-f32 read-f64
          write-uint write-u8 write-u16 write-u32 write-u64
          write-sint write-s8 write-s16 write-s32 write-s64
          write-ber-integer write-f16 write-f32 write-f64
          get-u8 get-u16 get-u32 get-u64 get-s8 get-s16 get-s32 get-s64
          get-f16 get-f32 get-f64
          get-u16be get-u16le get-u32be get-u32le get-u64be get-u64le
          get-s16be get-s16le get-s32be get-s32le get-s64be get-s64le
          get-f16be get-f16le get-f32be get-f32le get-f64be get-f64le
          put-u8! put-u16! put-u32! put-u64! put-s8! put-s16! put-s32! put-s64!
          put-f16! put-f32! put-f64!
          put-u16be! put-u16le! put-u32be! put-u32le! put-u64be! put-u64le!
          put-s16be! put-s16le! put-s32be! put-s32le! put-s64be! put-s64le!
          put-f16be! put-f16le! put-f32be! put-f32le! put-f64be! put-f64le!
          
          ;; old names
          read-binary-uint
          read-binary-uint8 read-binary-uint16
          read-binary-uint32 read-binary-uint64
          read-binary-sint
          read-binary-sint8 read-binary-sint16
          read-binary-sint32 read-binary-sint64
          read-binary-short  read-binary-ushort
          read-binary-long   read-binary-ulong
          read-binary-float read-binary-double
          write-binary-uint
          write-binary-uint8 write-binary-uint16
          write-binary-uint32 write-binary-uint64
          write-binary-sint
          write-binary-sint8 write-binary-sint16
          write-binary-sint32 write-binary-sint64
          write-binary-short  write-binary-ushort
          write-binary-long   write-binary-ulong
          write-binary-float  write-binary-double
          ))
(select-module binary.io)

(dynamic-load "binary")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; config

(define-constant *bit-size* 2)   ;; hey, you never know :)
(define-constant *byte-size* 8)
(define-constant *byte-magnitude* (expt *bit-size* *byte-size*))
(define-constant *byte-mask* (- *byte-magnitude* 1))
(define-constant *byte-right-shift* (* -1 *byte-size*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; basic reading

;; mind-numblingly slow, consider a uvector approach but it doesn't
;; handle endianess
(define (read-uint size . args)
  (let-optionals* args ((port (current-input-port))
                        (endian (default-endian)))
    (case size
      ((1) (read-u8 port endian))
      ((2) (read-u16 port endian))
      ((4) (read-u32 port endian))
      ((8) (read-u64 port endian))
      (else
       (let loop ((ls '())
                  (cnt 0))
         (if (= cnt size)
           (fold (lambda (a b) (+ a (* b *byte-magnitude*)))
                 0
                 (if (eq? endian 'big-endian) (reverse ls) ls))
           (let1 byte (read-byte port)
             (if (eof-object? byte)
               byte
               (loop (cons byte ls) (+ cnt 1)))))))
      )))

(define (lognot-small int bytes)
  (logand (lognot int) (- (expt *bit-size* (* *byte-size* bytes)) 1)))

(define (uint->sint int bytes)
  (let ((highbit (- (* *byte-size* bytes) 1)))
    (if (logbit? highbit int)
      (* -1 (+ 1 (lognot-small int bytes)))
      int)))

(define (sint->uint int bytes)
  (if (< int 0)
    (+ 1 (lognot-small (abs int) bytes))
    int))

(define (read-sint size . args)
  (let-optionals* args ((port (current-input-port))
                        (endian (default-endian)))
    (case size
      ((1) (read-s8 port endian))
      ((2) (read-s16 port endian))
      ((4) (read-s32 port endian))
      ((8) (read-s64 port endian))
      (else
       (uint->sint (read-uint size port endian) size)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; basic writing

(define (write-uint size int . args)
  (let-optionals* args ((port (current-output-port))
                        (endian (default-endian)))
    (case size
      ((1) (write-u8 int port endian))
      ((2) (write-u16 int port endian))
      ((4) (write-u32 int port endian))
      ((8) (write-u64 int port endian))
      (else
       (let ((ls '()))
         ;; build a list of bytes
         (dotimes (i size)
           (push! ls (logand int *byte-mask*))
           (set! int (ash int *byte-right-shift*)))
         ;; reverse if big-endian
         (unless (eq? endian 'big-endian)
           (set! ls (reverse ls)))
         ;; write the list
         (for-each (cut write-byte <> port) ls))))))

(define (write-sint size int . args)
  (let-optionals* args ((port (current-output-port))
                        (endian (default-endian)))
    (case size
      ((1) (write-s8 int port endian))
      ((2) (write-s16 int port endian))
      ((4) (write-s32 int port endian))
      ((8) (write-s64 int port endian))
      (else
       (write-uint size (sint->uint int size) port endian)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; compatibility
;;

;; These are used in binary.pack for the (unofficial) features to
;; read/write integers in "native" width of C system on the platform.
;; Should be removed soon (after binary.pack rewrite).  Do not use them.
(define read-binary-short  read-s16)
(define read-binary-ushort read-u16)
(define read-binary-long   read-s32)
(define read-binary-ulong  read-u32)

(define write-binary-short  write-s16)
(define write-binary-ushort write-u16)
(define write-binary-long   write-s32)
(define write-binary-ulong  write-u32)

;; Other compatibility names.  They have been official befor 0.8.10,
;; and used widely.  So we keep them for a while.
(define read-binary-uint  read-uint)
(define read-binary-sint  read-sint)
(define read-binary-uint8 read-u8)
(define read-binary-sint8 read-s8)
(define read-binary-uint16 read-u16)
(define read-binary-sint16 read-s16)
(define read-binary-uint32 read-u32)
(define read-binary-sint32 read-s32)
(define read-binary-uint64 read-u64)
(define read-binary-sint64 read-s64)
(define read-binary-float  read-f32)
(define read-binary-double read-f64)

(define write-binary-uint  write-uint)
(define write-binary-sint  write-sint)
(define write-binary-uint8 write-u8)
(define write-binary-sint8 write-s8)
(define write-binary-uint16 write-u16)
(define write-binary-sint16 write-s16)
(define write-binary-uint32 write-u32)
(define write-binary-sint32 write-s32)
(define write-binary-uint64 write-u64)
(define write-binary-sint64 write-s64)
(define write-binary-float  write-f32)
(define write-binary-double write-f64)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; bignum encodings -- Basic Encoding Rules (BER) from X.209

;; A BER compressed integer is an unsigned integer in base 128, most
;; significant digit first, where the high bit is set on all but the
;; final (least significant) byte.  Thus any size integer can be
;; encoded, but the encoding is efficient and small integers don't take
;; up any more space than they would in normal char/short/int encodings.

(define (read-ber-integer . opt-port)
  (let ((port (get-optional opt-port (current-input-port))))
    (let ((first (read-byte port)))
      (if (eof-object? first)
        first ;; stop on eof
        (if (< first 128)
          first
          (let loop ((res (ash (logand first #b01111111) 7))
                     (byte (read-u8 port)))
            (if (< byte 128)
              (+ res byte) ;; final byte
              (loop (ash (+ res (logand byte #b01111111)) 7)
                    (read-u8 port)))))))))

(define (write-ber-integer number . opt-port)
  (let ((port (get-optional opt-port (current-output-port))))
    (let ((final (logand number #b01111111))
          (start (ash number -7)))
      (unless (zero? start)
        (let loop ((n start))
          (cond ((< n 128)
                 (write-u8 (logior n #b10000000)))
                (else
                 (loop (ash n -7)) ;; write high bytes first
                 (write-u8 (logior (logand n #b01111111) #b10000000))))))
      (write-u8 final))))

(provide "binary/io")

