}

// Vector of generic values.
message Vector {
  repeated Value slot = 1;
}

// Associative array of generic keys and values. In order to maintain
// stability of reference numbers, (de-)serialization routines always
// process the test, hash and initial values before all slot values in
// sequence. The pairs constituting the slots are not tracked with
// reference numbers.
message HashTable {
  repeated Pair slot = 1;
  optional Value test = 2; // default = equal?
  optional Value hash = 3; // default = equal?-hash
  optional double min_load = 4 [default = 0.5];
  optional double max_load = 5 [default = 0.8];
  optional bool weak_keys = 6 [default = false]; // for future extensions
  optional bool weak_values = 7 [default = false]; // for future extensions
  optional Value initial = 8; // default = #f
}

// Closure with generic upvalues and code identifier.
message Procedure {
  repeated Value slot = 1;
  required string id = 2;
}

// Custom serialized value. In order to maintain stability of
// reference numbers, (de-)serialization always processes the custom
// reader before the custom data.
message Custom {
  required bytes data = 1;
  optional Value reader = 2;
}

	(write-tag/type 1 'sized port)
	(write-sized write-value (##sys#slot block i) port))))

  (define write-vector
    (write-block 0))

  (define (write-hash-table v port)





    (let ([v (hash-table-equivalence-function v)])
      (unless (eq? v equal?)
        (write-tag/type 2 'sized port)
	(write-sized write-value v port)))
    (let ([v (hash-table-hash-function v)])
      (unless (eq? v equal?-hash)
        (write-tag/type 3 'sized port)

    (let ([v (hash-table-weak-values v)])
      (when v
	(write-tag/type 7 'int* port)
	(write-bool v port)))
    (let ([v (hash-table-initial v)])
      (when v
	(write-tag/type 8 'sized port)
	(write-sized write-value v port)))
    (hash-table-walk
     v
     (lambda (k v)
       (write-tag/type 1 'sized port)
       (write-sized write-pair (cons k v) port))))

  (define write-procedure
    (let ([write-upvalues (write-block 1)])
      (lambda (v port)
	(write-tag/type 2 'sized port)
	(write-sized-string (%procedure-id v) port)
	(write-upvalues v port))))

  (define ((write-custom info) v port)


    (let ([reader (serialization-info-reader info)])
      (unless (eq? reader read)
	(write-tag/type 2 'sized port)
	(write-sized write-value reader port)))
    (write-tag/type 1 'sized port)
    (write-sized (serialization-info-writer info) v port))

  (define (write-value v port)
    (cond
     [(eq? v (void))
      (write-tag/type 1 'int* port)
      (write-int* 1 port)]
     [(null? v)

  (unless context
    (set! context
      (make-serialization-context
       (current-input-port) (current-output-port) (current-error-port))))
  (set! remember!
    (serialization-context-rememberer context))
  (parameterize ([current-serialization-context context])
    (write-value v port)))

(define (ensure-type expected actual value)
  (unless (eq? expected actual)
    (syntax-error
     'deserialize (string-append "bad wire type for " value)
     actual)))

(define (reverse!/length tail)
  (let next ([head '()] [tail tail] [length 0])
    (if (pair? tail)
	(let ([rest (cdr tail)])
	  (set-cdr! tail head)
	  (next tail rest (fx+ length 1)))
	(values head length))))

(define-record-type (hash-table-dummy
		     #:opaque #t #:sealed #t)
  #t #t
  test hash
  min-load max-load
  weak-keys weak-values
  initial size slots)

(define-record-type (custom-dummy
		     #:opaque #t #:sealed #t)
  #t #f
  data reader)

(define (deserialize #!optional [port (current-input-port)] [context (current-serialization-context)])
  (define remember!
    void)








  (define (read-real port)
    (let more ([v 1])
      (let-values ([(tag type) (read-tag/type port)])
	(case tag
	  [(1)
	   (ensure-type 'int* type "numerator")
	   (more (* v (read-sint* port #f)))]

	  [(#!eof)
	   (if id
	       (import-symbol id)
	       (syntax-error 'deserialize "missing symbol id"))]
	  [else
	   (syntax-error 'deserialize "unknown symbol part" tag)]))))

  (define ((read-pair! v) port)
    (let more ()
      (let-values ([(tag type) (read-tag/type port)])
	(case tag
	  [(1)
	   (ensure-type 'sized type "car")
	   (set-car! v (read-sized read-value port))
	   (more)]
	  [(2)
	   (ensure-type 'sized type "cdr")
	   (set-cdr! v (read-sized read-value port))
	   (more)]
	  [(#!eof)

	   v]
	  [else
	   (syntax-error 'deserialize "unknown pair part" tag)]))))

  (define ((read-block read-special make-block) port)
    (let more ([slots '()] [specials '()])

      (let-values ([(tag type) (read-tag/type port)])
	(case tag
	  [(1)
	   (ensure-type 'sized type "slot")
	   (more (cons (read-sized-string port) slots) specials)]
	  [(#!eof)

	   (let-values ([(slots length) (reverse!/length slots)])
	     (apply make-block length slots specials))]
	  [else
	   (let-values ([special (read-special tag type port)])
	     (more slots (append special specials)))]))))

  (define ((decode-block! i0) v)
    (do-ec (:range i i0 (##sys#size v))
      (##sys#setslot v i (call-with-input-string (##sys#slot v i) read-value)))
    v)

  (define read-vector*
    (read-block
     (lambda (tag type port)
       (syntax-error 'deserialize "unknown vector part" tag))
     (lambda (n slots)
       (vector-of-length-ec n (:list s slots) s))))

  (define decode-vector!
    (decode-block! 0))

  (define read-hash-table*
    (read-block




     (lambda (tag type port)
       (case tag
	 [(2)
	  (ensure-type 'sized type "equality function")

	  (values #:test (read-sized-string port))]

	 [(3)
	  (ensure-type 'sized type "hash function")
	  (values #:hash (read-sized-string port))]
	 [(4)
	  (ensure-type '64bit type "minimum load factor")
	  (values #:min-load (read-double port))]
	 [(5)
	  (ensure-type '64bit type "maximum load factor")
	  (values #:max-load (read-double port))]
	 [(6)
	  (ensure-type 'int* type "weak keys flag")
	  (values #:weak-keys (read-bool port))]
	 [(7)
	  (ensure-type 'int* type "weak values flag")
	  (values #:weak-values (read-bool port))]
	 [(8)
	  (ensure-type 'sized type "initial value")


	  (values #:initial (read-sized-string port))]

	 [else
	  (syntax-error 'deserialize "unknown hash table part" tag)]))
     (lambda (n slots #!key test hash [min-load 0.5] [max-load 0.8] weak-keys weak-values initial)
       (if (or test hash initial)
	   (make-hash-table-dummy
	    test hash min-load max-load weak-keys weak-values initial



	    n slots)
	   (alist->hash-table
	    (list (cons 'slots slots))
	    #:min-load min-load #:max-load max-load
	    #:weak-keys weak-keys #:weak-values weak-values
	    #:size n)))))

  (define (decode-hash-table! v)
    (let ([slots
	   (if (hash-table-dummy? v)
	       (let* ([test
		       (cond
			[(hash-table-dummy-test v) => decode-value]
			[else equal?])]
		      [hash
		       (cond
			[(hash-table-dummy-hash v) => decode-value]
			[else equal?-hash])]
		      [min-load

		       (hash-table-dummy-min-load v)]
		      [max-load
		       (hash-table-dummy-max-load v)]
		      [weak-keys
		       (hash-table-dummy-weak-keys v)]
		      [weak-values
		       (hash-table-dummy-weak-values v)]
		      [initial
		       (cond
			[(hash-table-dummy-initial v) => decode-value]
			[else #f])]

		      [size
		       (hash-table-dummy-size v)]
		      [slots
		       (hash-table-dummy-slots v)])
		 (object-become!
		  (list
		   (cons
		    v
		    (make-hash-table
		     #:test test #:hash hash
		     #:min-load min-load #:max-load max-load

		     #:weak-keys weak-keys #:weak-values weak-values

		     #:initial initial #:size size))))
		 slots)
	       (let ([slots (hash-table-ref v 'slots)])
		 (hash-table-delete! v 'slots)
		 slots))])
      (do-ec (:list s slots)
	(let ([k+v (call-with-input-string s (read-pair! (cons #f #f)))])
	  (hash-table-set! v (car k+v) (cdr k+v)))))
    v)

  (define read-procedure*
    (read-block
     (lambda (tag type port)
       (case tag



	 [(2)
	  (ensure-type 'sized type "procedure id")
	  (read-sized-string port)]









	 [else
	  (syntax-error 'deserialize "unknown procedure part" tag)]))
     (lambda (n slots #!optional id)
       (let ([v (##sys#allocate-vector (fx+ n 1) #f (void) #f)])
	 (unless (%procedure-id-set! v id)
	   (syntax-error 'deserialize "invalid procedure id" id))
	 (do-ec (:list s (index i) slots) (##sys#setslot v (fx+ i 1) s))
	 v))))

  (define decode-procedure!
    (decode-block! 1))

  (define read-custom*
    (read-block
     (lambda (tag type port)
       (case tag



	 [(2)
	  (ensure-type 'sized type "custom reader")
	  (read-sized-string port)]


	 [else
	  (syntax-error 'deserialize "unknown custom value part" tag)]))
     (lambda (n data #!optional reader)
       (make-custom-dummy (string-concatenate data) reader))))

  (define (decode-custom! v)
    (object-become!
     (list

      (cons
       v
       (call-with-input-string
	(custom-dummy-data v)
	(cond

	 [(custom-dummy-reader v) => decode-value]
	 [else read])))))
    v)

  (define read-record*
    (read-block
     (lambda (tag type port)
       (syntax-error 'deserialize "unknown record part" tag))
     (lambda (n slots #!optional id)
       (let ([v (##sys#allocate-vector n #f (void) #f)])
	 (##core#inline "C_vector_to_structure" v)
	 (do-ec (:list s (index i) slots) (##sys#setslot v i s))
	 v))))

  (define (read-value port)
    (let-values ([(tag type) (read-tag/type port)])
      (case tag
	[(1)
	 (ensure-type 'int* type "special value")
	 (let ([tag (read-int* port)])

	 (remember! (read-sized-string port))]
	[(7)
	 (ensure-type 'sized type "symbol")
	 (remember! (read-sized read-symbol port))]

	[(8)
	 (ensure-type 'sized type "pair")
	 (read-sized (read-pair! (remember! (cons #f #f))) port)]
	[(9)
	 (ensure-type 'sized type "vector")
	 (decode-vector! (remember! (read-sized read-vector* port)))]
	[(10)
	 (ensure-type 'sized type "hash table")
	 (decode-hash-table! (remember! (read-sized read-hash-table* port)))]

	[(11)
	 (ensure-type 'sized type "procedure")
	 (decode-procedure! (remember! (read-sized read-procedure* port)))]
	[(12)
	 (ensure-type 'sized type "lambda info")
	 (remember! (##sys#make-lambda-info (read-sized-string port)))]

	[(16)
	 (ensure-type 'sized type "u8vector")
	 (remember! (read-sized-bytes port))]

	[(26)
	 (ensure-type 'sized type "blob")
	 (remember!
	  (u8vector->blob/shared (read-sized-bytes port)))]

	[(13)
	 (ensure-type 'sized type "custom value")
	 (decode-custom! (remember! (read-sized read-custom* port)))]
	[(14)
	 (ensure-type 'sized type "record")
	 (decode-vector! (remember! (read-sized read-record* port)))]
	[(15)
	 (ensure-type 'int* type "shared structure")
	 (let ([tag (read-uint* port)])
	   (hash-table-ref
	    (serialization-context-ref->obj context) tag
	    (lambda ()
	      (syntax-error 'deserialize "unknown shared structure" tag))))]

	[(#!eof)
	 tag]
	[else
	 (syntax-error 'deserialize "unknown value type" tag)])))

  (define decode-value
    (cut call-with-input-string <> read-value))

  (unless context
    (set! context
      (make-serialization-context
       (current-input-port) (current-output-port) (current-error-port))))
  (set! remember!
    (let ([rememberer (serialization-context-rememberer context)])
      (lambda (v)
	(rememberer v)
	v)))
  (parameterize ([current-serialization-context context])
    (read-value port)))

;; 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.

(require-library
 srfi-4 srfi-13 srfi-18 srfi-42 srfi-4-comprehensions srfi-69 srfi-99
 ports extras
 numbers)

(module protobuf-encoding
  (make-limited-input-port
   read-uint* write-uint*
   read-sint* write-sint*

   serialization-info prop:serialization-info
   make-serialization-info serialization-info?
   serialization-info-reader serialization-info-writer
   serialize
   deserialize)
  (import
   scheme (except chicken define-record-type) foreign
   srfi-4 srfi-13 srfi-42 srfi-4-comprehensions srfi-69 srfi-99
   ports numbers lolevel
   protobuf-encoding)
  (include "generic.scm"))

 'protobuf
 '("protobuf.so"
   "protobuf-encoding.import.so"
   "protobuf-reflection.import.so"
   "protobuf-syntax.import.so"
   "protobuf.import.so"
   "protobuf-generic.import.so")
 '((version "1.1.1")))

(compile -O2 ,-d* "protoc-gen-chicken.scm")

(install-program
 'protoc-gen-chicken
 `("protoc-gen-chicken"
   ("extend/protobuf/bigint.proto"
    ,(make-pathname
      (list (installation-prefix) "include/extend/protobuf")
      "bigint.proto"))
   ("extend/protobuf/chicken.proto"
    ,(make-pathname
      (list (installation-prefix) "include/extend/protobuf")
      "chicken.proto")))
 '((version "1.1.1")))

	 [lst1 (serialize+deserialize lst0)])
    (check (eq? (cdddr lst1) lst1) => #t)
    (check (car lst1) => (car lst0))
    (check (cadr lst1) => (cadr lst0))
    (check (caddr lst1) => (caddr lst0)))
  
  (check-invariance '#(42+23i "foo"))

  (let ([vec0 (vector 'a 'b (void))])
    (vector-set! vec0 2 vec0)
    (let ([vec1 (serialize+deserialize vec0)])
      (check (eq? (vector-ref vec1 2) vec1) => #t)
      (check (vector-ref vec1 0) (=> eq?) (vector-ref vec0 0))
      (check (vector-ref vec1 1) (=> eq?) (vector-ref vec0 1))))
  
  (let* ([lst0 '(("blubb" . 23) ("boing" . 42))]
	 [lst1 (sort
		(hash-table->alist
		 (serialize+deserialize
		  (alist->hash-table lst0 #:test string=? #:hash string-hash)))
		(lambda (a b)
		  (string<? (car a) (car b))))])
    (check lst1 => lst0))
  
  (let* ([lst0 '((3 . "boo") (55 . "hoo"))]
	 [lst1 (sort
		(hash-table->alist
		 (serialize+deserialize
		  (alist->hash-table lst0)))
		(lambda (a b)
		  (< (car a) (car b))))])
    (check lst1 => lst0))
  
  (check ((serialize+deserialize (lambda (x) (* x 42))) 2) => 84)
  
  (check-invariance '#u8(1 2 3))
  (check-invariance '#s8(-1 0 +1))
  (check-invariance '#u16(1 2 3))
  (check-invariance '#s16(-1 0 +1))

 (prefix tests-main main-)
 (prefix tests-generic generic-))

(main-run)
(generic-run)

(check-report)
(exit (if (check-passed? 90) 0 1))