;; -*- mode: Scheme; -*-
;;
;; This file is part of Protocol Buffers for CHICKEN
;; Copyright (c) 2013 by Thomas Chust.  All rights reserved.
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the Software), to deal in the Software without restriction,
;; including without limitation the rights to use, copy, modify,
;; merge, publish, distribute, sublicense, and/or sell copies of the
;; Software, and to permit persons to whom the Software is furnished
;; to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

(define (make-limited-input-port in limit close-orig?)
  (make-input-port
   #;read
   (lambda ()
     (if (fx> limit 0)
         (begin
           (set! limit (fx- limit 1))
           (read-char in))
         #!eof))
   #;ready?
   (lambda ()
     (and (fx> limit 0)
          (char-ready? in)))
   #;close
   (lambda ()
     (if close-orig?
         (close-input-port in)
         (void)))
   #;peek
   (lambda ()
     (if (fx> limit 0)
         (peek-char in)
         #!eof))))

(define (read-uint* #!optional [port (current-input-port)] [max-size 10])
  (let loop ([span 0])
    (if (and max-size (>= span max-size))
        (syntax-error 'read-uint* "maximum integer size exceeded" max-size)
        (let ((b (read-byte port)))
          (if (and (not (eof-object? b)) (bit->boolean b 7))
              (+ (bitwise-and b #x7f)
                 (* 128 (loop (add1 span))))
              b)))))

(define (write-uint* n #!optional [port (current-output-port)] [max-size 10])
  (let loop ([n n] [span 0])
    (if (and max-size (>= span max-size))
        (syntax-error 'write-uint* "maximum integer size exceeded" max-size)
        (let*-values ([(r b) (quotient&remainder n 128)]
                      [(last?) (zero? r)])
          (write-byte (if last? b (bitwise-ior #x80 b)) port)
          (unless last? (loop r (add1 span)))))))

(define (read-sint* #!optional [port (current-input-port)] [max-size 10])
  (let ([z (read-uint* port max-size)])
    (if (eof-object? z)
        z
        (/ (if (odd? z) (- -1 z) z)
           2))))

(define (write-sint* i #!optional [port (current-output-port)] [max-size 10])
  (let ([2i (* 2 i)])
    (write-uint* (if (negative? i) (- -1 2i) 2i) port max-size)))

(define (read-int* #!optional [port (current-input-port)])
  (let ([n (read-uint* port)])
    (if (eof-object? n)
        n
        (if (positive? (- n #x8000000000000000))
            (- n #x10000000000000000)
            n))))

(define (write-int* i #!optional [port (current-output-port)])
  (write-uint* (if (negative? i) (+ i #x10000000000000000) i) port))

(define (read-bool #!optional [port (current-input-port)])
  (let ([n (read-uint* port)])
    (if (eof-object? n) n (not (zero? n)))))

(define (write-bool v #!optional [port (current-output-port)])
  (write-uint* (if v 1 0) port))

(define ((read-fixed* size signed?) #!optional [port (current-input-port)])
  (let ([bstr (read-u8vector size port)])
    (if (eof-object? bstr)
        bstr
        (let ([span (u8vector-length bstr)])
          (if (< span size)
              (syntax-error 'read-fixed* "found truncated fixed integer bytes")
              (let ([unsigned
                     (sum-ec (:u8vector b (index i) bstr)
                       (arithmetic-shift b (fx* i 8)))])
                (if (and signed? (bit->boolean unsigned (fx- (fx* size 8) 1)))
                    (- unsigned (arithmetic-shift 1 (fx* size 8)))
                    unsigned)))))))

(define read-fixed32
  (read-fixed* 4 #f))
(define read-fixed64
  (read-fixed* 8 #f))
(define read-sfixed32
  (read-fixed* 4 #t))
(define read-sfixed64
  (read-fixed* 8 #t))

(define ((write-fixed* size signed?) n #!optional [port (current-output-port)])
  (let* ([unsigned
          (if (and signed? (negative? n))
              (+ (arithmetic-shift 1 (fx* size 8)) n)
              n)]
         [bstr
          (u8vector-of-length-ec size (:range i size)
            (bitwise-and (arithmetic-shift unsigned (fx* i -8)) #xff))])
    (write-u8vector bstr port)))

(define write-fixed32
  (write-fixed* 4 #f))
(define write-fixed64
  (write-fixed* 8 #f))
(define write-sfixed32
  (write-fixed* 4 #t))
(define write-sfixed64
  (write-fixed* 8 #t))

(define ((read-float* size) #!optional [port (current-input-port)])
  (let ([bstr (read-u8vector size port)])
    (if (eof-object? bstr)
        bstr
        (let ([span (u8vector-length bstr)])
          (cond
           ((< span size)
            (syntax-error 'read-float* "found truncated fixed floating point bytes"))
           ((= size 8)
            (f64vector-ref (blob->f64vector/shared (u8vector->blob/shared bstr)) 0))
           ((= size 4)
            (f32vector-ref (blob->f32vector/shared (u8vector->blob/shared bstr)) 0))
           (else
            (error 'read-float* "only 64-bit and 32-bit floating point values are supported")))))))

(define read-float
  (read-float* 4))
(define read-double
  (read-float* 8))

(define ((write-float* size) x #!optional [port (current-output-port)])
  (write-u8vector
   (blob->u8vector/shared
    (cond
     ((= size 8)
      (f64vector->blob/shared (f64vector x)))
     ((= size 4)
      (f32vector->blob/shared (f32vector x)))
     (else
      (error 'write-float* "only 64-bit and 32-bit floating point values are supported"))))
   port))

(define write-float
  (write-float* 4))
(define write-double
  (write-float* 8))

(define (read-sized-bytes #!optional [port (current-input-port)])
  (let ([size (read-uint* port)])
    (if (eof-object? size)
        size
        (let ([bstr (read-u8vector size port)])
          (if (or (eof-object? bstr) (< (u8vector-length bstr) size))
              (syntax-error 'read-sized-bytes "found truncated bytes")
              bstr)))))

(define (write-sized-bytes bstr #!optional [port (current-output-port)])
  (write-uint* (u8vector-length bstr) port)
  (write-u8vector bstr port))

(define (read-sized-string #!optional [port (current-input-port)])
  (let ([size (read-uint* port)])
    (if (eof-object? size)
        size
        (let ([bstr (read-string size port)])
          (if (or (eof-object? bstr) (< (string-length bstr) size))
              (syntax-error 'read-sized-string "found truncated bytes")
              bstr)))))

(define (write-sized-string bstr #!optional [port (current-output-port)])
  (write-uint* (string-length bstr) port)
  (write-string bstr #f port))

(define (read-sized read #!optional [port (current-input-port)])
  (let ([size (read-uint* port)])
    (if (eof-object? size)
        size
        (let ([v (read (make-limited-input-port port size #f))])
          (if (eof-object? v)
              (syntax-error 'read-sized "found truncated data")
              v)))))

(define (write-sized write v #!optional [port (current-output-port)])
  (let ([bstr (call-with-output-string (cut write v <>))])
    (write-uint* (string-length bstr) port)
    (write-string bstr #f port)))

(define (read-tag/type #!optional [port (current-input-port)])
  (let ([tag/type (read-uint* port)])
    (if (eof-object? tag/type)
        (values tag/type
                tag/type)
        (values (arithmetic-shift tag/type -3)
                (let ([type (bitwise-and tag/type #b111)])
                  (case type
                    [(0) 'int*]
                    [(1) '64bit]
                    [(5) '32bit]
                    [(2) 'sized]
                    [else (syntax-error 'read-tag/type "found unknown field type" type)]))))))

(define (write-tag/type tag type #!optional [port (current-output-port)])
  (write-uint*
   (bitwise-ior
    (arithmetic-shift tag 3)
    (case type
      [(int*) 0]
      [(64bit) 1]
      [(32bit) 5]
      [(sized) 2]))
   port))

;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;;