Copyright (C) 2011-2013 Thomas Chust <chust@web.de>.  All rights reserved.
Copyright (C) 2011-2018 Thomas Chust <chust@web.de>. 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:

;; -*- 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))
         (begin
           (set! limit (fx- limit 1))
           (read-char in))
         #!eof))
   #;ready?
   (lambda ()
     (and (fx> limit 0)
	  (char-ready? in)))
          (char-ready? in)))
   #;close
   (lambda ()
     (if close-orig?
	 (close-input-port in)
	 (void)))
         (close-input-port in)
         (void)))
   #;peek
   (lambda ()
     (if (fx> limit 0)
	 (peek-char in)
	 #!eof))))
         (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-set? b 7))
	      (+ (bitwise-and b #x7f)
		 (* 128 (loop (add1 span))))
	      b)))))
        (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)
        (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)))))))
          (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
        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-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-set? unsigned (fx- (fx* size 8) 1)))
		    (- unsigned (arithmetic-shift 1 (fx* size 8)))
		    unsigned)))))))
              (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))])
          (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")))))))
           ((< 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)])

(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")
              (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")
              (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")
              (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)))

    (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: ;;

;; Generated by protoc-gen-chicken v1.0.0
;; Generated by protoc-gen-chicken v1.1.3
(module
  extend-protobuf
  *
  (import
  (import (except scheme string) chicken protobuf-syntax google-protobuf)
    (except scheme string)
    (chicken base)
    protobuf-syntax
    google-protobuf)
  (define-message-extension field-options (optional uint32 max-size 76884 10)))

// 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

  optional bytes u8vector = 16;
  optional bytes s8vector = 17;
  repeated uint32 u16vector = 18 [packed = true];
  repeated sint32 s16vector = 19 [packed = true];
  repeated uint32 u32vector = 20 [packed = true];
  repeated sint32 s32vector = 21 [packed = true];
  repeated uint64 u64vector = 22 [packed = true]; // for future extensions
  repeated sint64 s64vector = 23 [packed = true]; // for future extensions
  repeated uint64 u64vector = 22 [packed = true];
  repeated sint64 s64vector = 23 [packed = true];
  repeated float f32vector = 24 [packed = true];
  repeated double f64vector = 25 [packed = true];
  optional bytes blob = 26;

  optional Custom custom = 13;
  optional Vector record = 14;
  optional uint64 shared = 15;
}

// Arbitrary precision real numeric value. Either n or x should be set.
// Arbitrary precision real numeric value. Either numer or flonum should be set.
message Real {
  optional sint64 numer = 1 [(extend.protobuf.max_size) = 0];
  optional sint64 denom = 2 [default = 1, (extend.protobuf.max_size) = 0];
  optional double flonum = 3;
}

// Arbitrary precision complex numeric value.

;; -*- 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-identifier
  (let ([camel (sre->irregex '(: ($ lower) ($ upper)))]
	[score (sre->irregex '("._"))])
        [score (sre->irregex '("._"))])
    (lambda (str #!optional prefix)
      (string->symbol
       (conc
	(or prefix "")
	(if prefix ":" "")
	(string-downcase
	 (irregex-replace/all
	  score (irregex-replace/all camel str 1 "-" 2) "-")))))))
        (or prefix "")
        (if prefix ":" "")
        (string-downcase
         (irregex-replace/all
          score (irregex-replace/all camel str 1 "-" 2) "-")))))))

(define (proto-file-register! types file)
  (define name
    (file-descriptor-proto-package file "main"))
  (define module
    (make-identifier name))

  (define (register-identifier! path name prefix)
    (let ([path (string-append path "." name)]
	  [prefix (make-identifier name prefix)])
          [prefix (make-identifier name prefix)])
      (hash-table-set! types path (cons module prefix))
      (values path prefix)))

  (define (register-enum! path enum #!optional prefix)
    (register-identifier! path (enum-descriptor-proto-name enum) prefix))
  

  (define (register-message! path msg #!optional prefix)
    (let-values ([(path prefix)
		  (register-identifier!
		   path (descriptor-proto-name msg) prefix)])
                  (register-identifier!
                   path (descriptor-proto-name msg) prefix)])
      (for-each
       (cut register-enum! path <> prefix)
       (descriptor-proto-enum-type msg '()))
      (for-each
       (cut register-message! path <> prefix)
       (descriptor-proto-nested-type msg '()))))
  

  (let ([path (string-append "." name)])
    (for-each
     (cut register-enum! path <>)
     (file-descriptor-proto-enum-type file '()))
    (for-each
     (cut register-message! path <>)
     (file-descriptor-proto-message-type file '()))))

(define (proto-file-translate types file)
  (define module
    (make-identifier (file-descriptor-proto-package file "main")))

  (define imports
    (make-hash-table eq? symbol-hash))

  (define (resolve-identifier! name prefix)
    (let-values ([(module symbol)
		  (car+cdr
		   (hash-table-ref
		    types name
		    (cut error prefix "unknown type" name)))])
                  (car+cdr
                   (hash-table-ref
                    types name
                    (cut error prefix "unknown type" name)))])
      (hash-table-set! imports module #t)
      symbol))

  (define (translate-enum-definition enum #!optional prefix)
    (let ([name (make-identifier (enum-descriptor-proto-name enum) prefix)])
      `((define-enum-type ,name
	  ,@(map
	     (lambda (item)
	       (list
		(make-identifier (enum-value-descriptor-proto-name item))
		(enum-value-descriptor-proto-number item)))
	     (enum-descriptor-proto-value enum '()))))))
  
          ,@(map
             (lambda (item)
               (list
                (make-identifier (enum-value-descriptor-proto-name item))
                (enum-value-descriptor-proto-number item)))
             (enum-descriptor-proto-value enum '()))))))

  (define (translate-field field prefix)
    (let ([name (make-identifier (field-descriptor-proto-name field))]
	  [options (field-descriptor-proto-options field make-field-options)])
          [options (field-descriptor-proto-options field make-field-options)])
      (cons*
       (case (field-descriptor-proto-label field)
	 [(label-required) 'required]
	 [(label-optional) 'optional]
	 [(label-repeated)
	  (if (field-options-packed options #f) 'packed 'repeated)])
         [(label-required) 'required]
         [(label-optional) 'optional]
         [(label-repeated)
          (if (field-options-packed options #f) 'packed 'repeated)])
       (case (field-descriptor-proto-type field)
	 [(type-int32) 'int32]
	 [(type-int64) 'int64]
	 [(type-uint32) 'uint32]
	 [(type-uint64)
	  (let ([max-size (field-options-max-size options)])
	    (if (= max-size 10)
		'uint64
		`(uint* ,(and (positive? max-size) max-size))))]
	 [(type-sint32) 'sint32]
	 [(type-sint64)
	  (let ([max-size (field-options-max-size options)])
	    (if (= max-size 10)
		'sint64
		`(sint* ,(and (positive? max-size) max-size))))]
	 [(type-fixed32) 'fixed32]
	 [(type-fixed64) 'fixed64]
	 [(type-sfixed32) 'sfixed32]
	 [(type-sfixed64) 'sfixed64]
	 [(type-bool) 'bool]
	 [(type-float) 'float]
	 [(type-double) 'double]
	 [(type-bytes) 'bytes]
	 [(type-string) 'string]
	 [else (resolve-identifier! (field-descriptor-proto-type-name field) name)])
         [(type-int32) 'int32]
         [(type-int64) 'int64]
         [(type-uint32) 'uint32]
         [(type-uint64)
          (let ([max-size (field-options-max-size options)])
            (if (= max-size 10)
                'uint64
                `(uint* ,(and (positive? max-size) max-size))))]
         [(type-sint32) 'sint32]
         [(type-sint64)
          (let ([max-size (field-options-max-size options)])
            (if (= max-size 10)
                'sint64
                `(sint* ,(and (positive? max-size) max-size))))]
         [(type-fixed32) 'fixed32]
         [(type-fixed64) 'fixed64]
         [(type-sfixed32) 'sfixed32]
         [(type-sfixed64) 'sfixed64]
         [(type-bool) 'bool]
         [(type-float) 'float]
         [(type-double) 'double]
         [(type-bytes) 'bytes]
         [(type-string) 'string]
         [else (resolve-identifier! (field-descriptor-proto-type-name field) name)])
       name
       (field-descriptor-proto-number field)
       (let ([default (field-descriptor-proto-default-value field void)])
	 (if (eq? default (void))
	     '()
	     (list
	      (case (field-descriptor-proto-type field)
		[(type-int32 type-int64
		  type-uint32 type-uint64
		  type-sint32 type-sint64
		  type-fixed32 type-fixed64
		  type-sfixed32 type-sfixed64
		  type-float type-double
		  type-bytes)
		 (call-with-input-string default read)]
		[(type-bool)
		 (not (equal? default "false"))]
		[(type-enum)
		 `(quote ,(make-identifier default))]
		[(type-string)
		 default]
		[else
		 (error prefix "unsupported default value" name default)])))))))
  
         (if (eq? default (void))
             '()
             (list
              (case (field-descriptor-proto-type field)
                [(type-int32 type-int64
                  type-uint32 type-uint64
                  type-sint32 type-sint64
                  type-fixed32 type-fixed64
                  type-sfixed32 type-sfixed64
                  type-float type-double
                  type-bytes)
                 (call-with-input-string default read)]
                [(type-bool)
                 (not (equal? default "false"))]
                [(type-enum)
                 `(quote ,(make-identifier default))]
                [(type-string)
                 default]
                [else
                 (error prefix "unsupported default value" name default)])))))))

  (define (translate-message-definition msg #!optional prefix)
    (let ([name (make-identifier (descriptor-proto-name msg) prefix)])
      (append
       (append-map
	(cut translate-enum-definition <> name)
	(descriptor-proto-enum-type msg '()))
        (cut translate-enum-definition <> name)
        (descriptor-proto-enum-type msg '()))
       (append-map
	(cut translate-message-definition <> name)
	(descriptor-proto-nested-type msg '()))
        (cut translate-message-definition <> name)
        (descriptor-proto-nested-type msg '()))
       (append-map
	translate-message-extension
	(descriptor-proto-extension msg '()))
        translate-message-extension
        (descriptor-proto-extension msg '()))
       `((define-message-type ,name
	   ,@(map
	      (cut translate-field <> name)
	      (descriptor-proto-field msg '())))))))
  
           ,@(map
              (cut translate-field <> name)
              (descriptor-proto-field msg '())))))))

  (define (translate-message-extension ext)
    (let ([name (resolve-identifier! (field-descriptor-proto-extendee ext) '<message-extension>)])
      `((define-message-extension ,name
	  ,(translate-field ext name)))))
  
          ,(translate-field ext name)))))

  (define body
    (append
     (append-map
      translate-enum-definition
      (file-descriptor-proto-enum-type file '()))
     (append-map
      translate-message-definition

  (make-code-generator-response:file
   #:name
   (pathname-replace-extension
    (file-descriptor-proto-name file) "scm")
   #:content
   (call-with-output-string
     (lambda (port)
       (display ";; Generated by protoc-gen-chicken v1.0.0" port)
       (display ";; Generated by protoc-gen-chicken v1.2.3" port)
       (newline port)
       (pretty-print
	`(module ,module
	   *
	   (import
	    (except scheme string) chicken protobuf-syntax
	    ,@(hash-table-keys imports))
	   ,@body)
	port)))))
        `(module ,module
           *
           (import
            (except scheme string) (chicken base) protobuf-syntax
            ,@(hash-table-keys imports))
           ,@body)
        port)))))

(define (generate-chicken request)
  (define files
    (make-hash-table string=? string-hash))
  (define types
    (make-hash-table string=? string-hash))

  (for-each
   (lambda (file)
     (hash-table-set! files (file-descriptor-proto-name file) file)
     (proto-file-register! types file))
   (code-generator-request-proto-file request '()))
  

  (condition-case
   (make-code-generator-response
    #:file
    (map
     (lambda (name)
       (proto-file-translate types (hash-table-ref files name)))
     (code-generator-request-file-to-generate request '())))
   [exn (exn)
    (make-code-generator-response
     #:error
     (call-with-output-string
      (cut print-error-message exn <>)))]))

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

;; -*- 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-record-type (serialization-context
		     #:uid 'protobuf:serialization-context
		     #:opaque #t #:sealed #t)
                     #:uid 'protobuf:serialization-context
                     #:opaque #t #:sealed #t)
  #f #t
  obj->ref
  ref->obj)

(define current-serialization-context
  (make-parameter #f))

(define make-serialization-context
  (let ([make-serialization-context* (rtd-constructor serialization-context)])
    (lambda vs
      (let* ([obj->ref (make-hash-table eq? eq?-hash)]
	     [ref->obj (make-hash-table eqv? eqv?-hash)]
	     [context (make-serialization-context* obj->ref ref->obj)])
	(do-ec (:list v (index ref) (cons context vs))
	  (begin
	    (hash-table-set! obj->ref v ref)
	    (hash-table-set! ref->obj ref v)))
	context))))
             [ref->obj (make-hash-table eqv? eqv?-hash)]
             [context (make-serialization-context* obj->ref ref->obj)])
        (do-ec (:list v (index ref) (cons context vs))
          (begin
            (hash-table-set! obj->ref v ref)
            (hash-table-set! ref->obj ref v)))
        context))))

(define (serialization-context-rememberer context)
  (let ([obj->ref (serialization-context-obj->ref context)]
	[ref->obj (serialization-context-ref->obj context)])
        [ref->obj (serialization-context-ref->obj context)])
    (lambda (v)
      (cond
       [(hash-table-ref/default obj->ref v #f)
      (or (hash-table-ref/default obj->ref v #f)
	=> values]
       [else
	(let ([ref (hash-table-size ref->obj)])
	  (hash-table-set! obj->ref v ref)
	  (hash-table-set! ref->obj ref v))
	#f]))))
          (let ([ref (hash-table-size ref->obj)])
            (hash-table-set! obj->ref v ref)
            (hash-table-set! ref->obj ref v)
            #f)))))

(define-record-property prop:serialization-info
  #f)

(define-record-type (serialization-info
		     #:uid 'protobuf:serialization-info)
                     #:uid 'protobuf:serialization-info)
  #t #t
  reader writer)

(define %procedure-id
  (foreign-lambda* c-string ([scheme-object proc])
    "C_return(C_lookup_procedure_id((void *) C_block_item(proc, 0)));"))

(define (serialize v #!optional [port (current-output-port)] [context (current-serialization-context)])
  (define remember!
    void)

  (define (write-real v port)
    (if (exact? v)
	(let ([numer (numerator v)]
	      [denom (denominator v)])
	  (unless (zero? numer)
	    (write-tag/type 1 'int* port)
	    (write-sint* numer port #f))
	  (unless (= 1 denom)
	    (write-tag/type 2 'int* port)
	    (write-sint* denom port #f)))
	(begin
	  (write-tag/type 3 '64bit port)
	  (write-double v port))))
        (let ([numer (numerator v)]
              [denom (denominator v)])
          (unless (zero? numer)
            (write-tag/type 1 'int* port)
            (write-sint* numer port #f))
          (unless (= 1 denom)
            (write-tag/type 2 'int* port)
            (write-sint* denom port #f)))
        (begin
          (write-tag/type 3 '64bit port)
          (write-double v port))))

  (define (write-complex v port)
    (let ([real (real-part v)]
	  [imag (imag-part v)])
          [imag (imag-part v)])
      (unless (zero? real)
	(write-tag/type 1 'sized port)
	(write-sized write-real real port))
        (write-tag/type 1 'sized port)
        (write-sized write-real real port))
      (unless (zero? imag)
	(write-tag/type 2 'sized port)
	(write-sized write-real imag port))))
        (write-tag/type 2 'sized port)
        (write-sized write-real imag port))))

  (define (write-keyword v port)
    (write-tag/type 1 'sized port)
    (write-sized-string (keyword->string v) port)
    (write-tag/type 2 'int* port)
    (write-int* 3 port))

  (define (write-symbol v port)
    (write-tag/type 1 'sized port)
    (write-sized-string (symbol->string v) port)
    (cond
     [(not (##sys#interned-symbol? v))
      (write-tag/type 2 'int* port)
      (write-int* 2 port)]
    (write-tag/type 2 'int* port)
    (write-int* (if (##sys#interned-symbol? v) 1 2) port))
     [(keyword? v)
      (write-tag/type 2 'int* port)
      (write-int* 3 port)]))

  (define (write-pair v port)
    (write-tag/type 1 'sized port)
    (write-sized write-value (car v) port)
    (write-tag/type 2 'sized port)
    (write-sized write-value (cdr v) port))

  (define ((write-block i0) block port)
    (do-ec (:range i i0 (##sys#size block))
      (begin
	(write-tag/type 1 'sized port)
	(write-sized write-value (##sys#slot block i) port))))
        (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)))
        (write-sized write-value v port)))
    (let ([v (hash-table-hash-function v)])
      (unless (eq? v equal?-hash)
        (write-tag/type 3 'sized port)
	(write-sized write-value v port)))
        (write-sized write-value v port)))
    (let ([v (hash-table-min-load v)])
      (unless (= v 0.5)
	(write-tag/type 4 '64bit port)
	(write-double v port)))
        (write-tag/type 4 '64bit port)
        (write-double v port)))
    (let ([v (hash-table-max-load v)])
      (unless (= v 0.8)
	(write-tag/type 5 '64bit port)
	(write-double v port)))
        (write-tag/type 5 '64bit port)
        (write-double v port)))
    (let ([v (hash-table-weak-keys v)])
      (when v
	(write-tag/type 6 'int* port)
	(write-bool v port)))
        (write-tag/type 6 'int* port)
        (write-bool v port)))
    (let ([v (hash-table-weak-values v)])
      (when v
	(write-tag/type 7 'int* port)
	(write-bool v port)))
        (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)))
        (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))))
        (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 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* (char->integer v) port)]
     [(fixnum? v)
      (write-tag/type 3 'int* port)
      (write-sint* v port)]

     [(remember! v)
      => (lambda (ref)
	   (write-tag/type 15 'int* port)
	   (write-uint* ref port))]
           (write-tag/type 15 'int* port)
           (write-uint* ref port))]

     [(number? v)
      (write-tag/type 5 'sized port)
      (write-sized write-complex v port)]
     [(string? v)
      (write-tag/type 6 'sized port)
      (write-sized-string v port)]
     [(keyword? v)
      (write-tag/type 7 'sized port)
      (write-sized write-keyword v port)]
     [(symbol? v)
      (write-tag/type 7 'sized port)
      (write-sized write-symbol v port)]
     [(pair? v)
      (write-tag/type 8 'sized port)
      (write-sized write-pair v port)]
     [(vector? v)

     [(s8vector? v)
      (write-tag/type 17 'sized port)
      (write-sized-bytes (blob->u8vector/shared (s8vector->blob/shared v)) port)]
     [(u16vector? v)
      (write-tag/type 18 'sized port)
      (write-sized
       (lambda (block port)
	 (do-ec (:u16vector v block) (write-uint* v port)))
         (do-ec (:u16vector v block) (write-uint* v port)))
       v port)]
     [(s16vector? v)
      (write-tag/type 19 'sized port)
      (write-sized
       (lambda (block port)
	 (do-ec (:s16vector v block) (write-sint* v port)))
         (do-ec (:s16vector v block) (write-sint* v port)))
       v port)]
     [(u32vector? v)
      (write-tag/type 20 'sized port)
      (write-sized
       (lambda (block port)
	 (do-ec (:u32vector v block) (write-uint* v port)))
         (do-ec (:u32vector v block) (write-uint* v port)))
       v port)]
     [(s32vector? v)
      (write-tag/type 21 'sized port)
      (write-sized
       (lambda (block port)
	 (do-ec (:s32vector v block) (write-sint* v port)))
         (do-ec (:s32vector v block) (write-sint* v port)))
       v port)]
     #;[(u64vector? v)
     [(u64vector? v)
      (write-tag/type 22 'sized port)
      (write-sized
       (lambda (block port)
	 (do-ec (:u64vector v block) (write-uint* v port)))
         (do-ec (:u64vector v block) (write-uint* v port)))
       v port)]
     #;[(s64vector? v)
     [(s64vector? v)
      (write-tag/type 23 'sized port)
      (write-sized
       (lambda (block port)
	 (do-ec (:s64vector v block) (write-sint* v port)))
         (do-ec (:s64vector v block) (write-sint* v port)))
       v port)]
     [(f32vector? v)
      (write-tag/type 24 'sized port)
      (write-sized-bytes (blob->u8vector/shared (f32vector->blob/shared v)) port)]
     [(f64vector? v)
      (write-tag/type 25 'sized port)
      (write-sized-bytes (blob->u8vector/shared (f64vector->blob/shared v)) port)]
     [(blob? v)
      (write-tag/type 26 'sized port)
      (write-sized-bytes (blob->u8vector/shared v) port)]

     [(record? v)
      (cond
       [(prop:serialization-info v)
	=> (lambda (info)
	     (write-tag/type 13 'sized port)
	     (write-sized (write-custom info) v port))]
        => (lambda (info)
             (write-tag/type 13 'sized port)
             (write-sized (write-custom info) v port))]
       [else
	(write-tag/type 14 'sized port)
	(write-sized write-vector v port)])]
        (write-tag/type 14 'sized port)
        (write-sized write-vector v port)])]

     [else
      (error 'serialize "cannot serialize value" v)]))

  (unless context
    (set! context
      (make-serialization-context

    (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))))
        (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)
                     #: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)
                     #: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)))]
	  [(2)
	   (ensure-type 'int* type "denominator")
	   (more (/ v (read-sint* port #f)))]
	  [(3)
	   (ensure-type '64bit type "flonum")
	   (more (read-double port))]
	  [(#!eof)
	   v]
	  [else
	   (syntax-error 'deserialize "unknown real part" tag)]))))
        (case tag
          [(1)
           (ensure-type 'int* type "numerator")
           (more (* v (read-sint* port #f)))]
          [(2)
           (ensure-type 'int* type "denominator")
           (more (/ v (read-sint* port #f)))]
          [(3)
           (ensure-type '64bit type "flonum")
           (more (read-double port))]
          [(#!eof)
           v]
          [else
           (syntax-error 'deserialize "unknown real part" tag)]))))

  (define (read-complex port)
    (let more ([real 0] [imag 0])
      (let-values ([(tag type) (read-tag/type port)])
	(case tag
	  [(1)
	   (ensure-type 'sized type "real part")
	   (more (read-sized read-real port) imag)]
	  [(2)
	   (ensure-type 'sized type "imaginary part")
	   (more real (read-sized read-real port))]
	  [(#!eof)
	   (make-rectangular real imag)]
	  [else
	   (syntax-error 'deserialize "unknown complex part" tag)]))))
        (case tag
          [(1)
           (ensure-type 'sized type "real part")
           (more (read-sized read-real port) imag)]
          [(2)
           (ensure-type 'sized type "imaginary part")
           (more real (read-sized read-real port))]
          [(#!eof)
           (make-rectangular real imag)]
          [else
           (syntax-error 'deserialize "unknown complex part" tag)]))))

  (define (read-symbol port)
    (let more ([id #f] [import-symbol string->symbol])
      (let-values ([(tag type) (read-tag/type port)])
	(case tag
	  [(1)
	   (ensure-type 'sized type "symbol id")
	   (more (read-sized-string port) import-symbol)]
	  [(2)
	   (ensure-type 'int* type "symbol type")
	   (let ([tag (read-int* port)])
	     (case tag
	       [(1) (more id string->symbol)]
	       [(2) (more id string->uninterned-symbol)]
	       [(3) (more id string->keyword)]
	       [else (syntax-error 'deserialize "unknown symbol type" tag)]))]
	  [(#!eof)
	   (if id
	       (import-symbol id)
	       (syntax-error 'deserialize "missing symbol id"))]
	  [else
	   (syntax-error 'deserialize "unknown symbol part" tag)]))))
        (case tag
          [(1)
           (ensure-type 'sized type "symbol id")
           (more (read-sized-string port) import-symbol)]
          [(2)
           (ensure-type 'int* type "symbol type")
           (let ([tag (read-int* port)])
             (case tag
               [(1) (more id string->symbol)]
               [(2) (more id string->uninterned-symbol)]
               [(3) (more id string->keyword)]
               [else (syntax-error 'deserialize "unknown symbol type" tag)]))]
          [(#!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)]))))
        (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)))]))))
        (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)]))
         [(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)))))
           (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))])
           (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)))))
        (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)]))
         [(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))))
         (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)]))
         [(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])))))
        (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))))
         (##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)])
	   (case tag
	     [(1) (void)]
	     [(2) '()]
	     [(3) #!eof]
	     [(4) #f]
	     [(5) #t]
	     [else (syntax-error 'deserialize "unknown special value" tag)]))]
	[(2)
	 (ensure-type 'int* type "char")
	 (integer->char (read-int* port))]
	[(3)
	 (ensure-type 'int* type "fixnum")
	 (read-sint* port)]
        [(1)
         (ensure-type 'int* type "special value")
         (let ([tag (read-int* port)])
           (case tag
             [(1) (void)]
             [(2) '()]
             [(3) #!eof]
             [(4) #f]
             [(5) #t]
             [else (syntax-error 'deserialize "unknown special value" tag)]))]
        [(2)
         (ensure-type 'int* type "char")
         (integer->char (read-int* port))]
        [(3)
         (ensure-type 'int* type "fixnum")
         (read-sint* port)]

	[(5)
	 (ensure-type 'sized type "number")
	 (remember! (read-sized read-complex port))]
	[(6)
	 (ensure-type 'sized type "string")
	 (remember! (read-sized-string port))]
	[(7)
	 (ensure-type 'sized type "symbol")
	 (remember! (read-sized read-symbol port))]
        [(5)
         (ensure-type 'sized type "number")
         (remember! (read-sized read-complex port))]
        [(6)
         (ensure-type 'sized type "string")
         (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)))]
        [(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)))]
        [(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))]
	[(17)
	 (ensure-type 'sized type "s8vector")
	 (remember! (blob->s8vector/shared (u8vector->blob/shared (read-sized-bytes port))))]
	[(18)
	 (ensure-type 'sized type "u16vector")
	 (remember!
	  (read-sized
	   (lambda (port)
	     (u16vector-ec (:port v port read-uint*) v))
	   port))]
	[(19)
	 (ensure-type 'sized type "s16vector")
	 (remember!
	  (read-sized
	   (lambda (port)
	     (s16vector-ec (:port v port read-sint*) v))
	   port))]
	[(20)
	 (ensure-type 'sized type "u32vector")
	 (remember!
	  (read-sized
	   (lambda (port)
	     (u32vector-ec (:port v port read-uint*) v))
	   port))]
	[(21)
	 (ensure-type 'sized type "s32vector")
	 (remember!
	  (read-sized
	   (lambda (port)
	     (s32vector-ec (:port v port read-sint*) v))
	   port))]
	#;[(22)
	 (ensure-type 'sized type "u64vector")
	 (remember!
	  (read-sized
	   (lambda (port)
	     (u64vector-ec (:port v port read-uint*) v))
	   port))]
	#;[(23)
	 (ensure-type 'sized type "s64vector")
	 (remember!
	  (read-sized
	   (lambda (port)
	     (s64vector-ec (:port v port read-sint*) v))
	   port))]
	[(24)
	 (ensure-type 'sized type "f32vector")
	 (remember!
	  (blob->f32vector/shared
	   (u8vector->blob/shared (read-sized-bytes port))))]
	[(25)
	 (ensure-type 'sized type "f64vector")
	 (remember!
	  (blob->f64vector/shared
	   (u8vector->blob/shared (read-sized-bytes port))))]
	[(26)
	 (ensure-type 'sized type "blob")
	 (remember!
	  (u8vector->blob/shared (read-sized-bytes port)))]
        [(16)
         (ensure-type 'sized type "u8vector")
         (remember! (read-sized-bytes port))]
        [(17)
         (ensure-type 'sized type "s8vector")
         (remember! (blob->s8vector/shared (u8vector->blob/shared (read-sized-bytes port))))]
        [(18)
         (ensure-type 'sized type "u16vector")
         (remember!
          (read-sized
           (lambda (port)
             (u16vector-ec (:port v port read-uint*) v))
           port))]
        [(19)
         (ensure-type 'sized type "s16vector")
         (remember!
          (read-sized
           (lambda (port)
             (s16vector-ec (:port v port read-sint*) v))
           port))]
        [(20)
         (ensure-type 'sized type "u32vector")
         (remember!
          (read-sized
           (lambda (port)
             (u32vector-ec (:port v port read-uint*) v))
           port))]
        [(21)
         (ensure-type 'sized type "s32vector")
         (remember!
          (read-sized
           (lambda (port)
             (s32vector-ec (:port v port read-sint*) v))
           port))]
        [(22)
         (ensure-type 'sized type "u64vector")
         (remember!
          (read-sized
           (lambda (port)
             (u64vector-ec (:port v port read-uint*) v))
           port))]
        [(23)
         (ensure-type 'sized type "s64vector")
         (remember!
          (read-sized
           (lambda (port)
             (s64vector-ec (:port v port read-sint*) v))
           port))]
        [(24)
         (ensure-type 'sized type "f32vector")
         (remember!
          (blob->f32vector/shared
           (u8vector->blob/shared (read-sized-bytes port))))]
        [(25)
         (ensure-type 'sized type "f64vector")
         (remember!
          (blob->f64vector/shared
           (u8vector->blob/shared (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))))]
        [(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)])))
        [(#!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)))
        (rememberer v)
        v)))
  (parameterize ([current-serialization-context context])
    (read-value port)))

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

;; Generated by protoc-gen-chicken v1.0.0
;; Generated by protoc-gen-chicken v1.1.3
(module
  google-protobuf-compiler
  *
  (import
  (import (except scheme string) chicken protobuf-syntax google-protobuf)
    (except scheme string)
    (chicken base)
    protobuf-syntax
    google-protobuf)
  (define-message-type
    code-generator-request
    (repeated string file-to-generate 1)
    (optional string parameter 2)
    (repeated file-descriptor-proto proto-file 15))
  (define-message-type
    code-generator-response:file

;; Generated by protoc-gen-chicken v1.0.0
;; Generated by protoc-gen-chicken v1.1.3
(module
  google-protobuf
  *
  (import (except scheme string) chicken protobuf-syntax)
  (import (except scheme string) (chicken base) protobuf-syntax)
  (define-message-type
    file-descriptor-set
    (repeated file-descriptor-proto file 1))
  (define-message-type
    file-descriptor-proto
    (optional string name 1)
    (optional string package 2)
    (repeated string dependency 3)
    (repeated int32 public-dependency 10)
    (repeated int32 weak-dependency 11)
    (repeated descriptor-proto message-type 4)
    (repeated enum-descriptor-proto enum-type 5)
    (repeated service-descriptor-proto service 6)
    (repeated field-descriptor-proto extension 7)
    (optional file-options options 8)
    (optional source-code-info source-code-info 9))
  (define-message-type
    descriptor-proto:extension-range
    (optional int32 start 1)
    (optional int32 end 2))
  (define-message-type
    descriptor-proto
    (optional string name 1)
    (repeated field-descriptor-proto field 2)
    (repeated field-descriptor-proto extension 6)
    (repeated descriptor-proto nested-type 3)
    (repeated enum-descriptor-proto enum-type 4)
    (repeated descriptor-proto:extension-range extension-range 5)
    (repeated oneof-descriptor-proto oneof-decl 8)
    (optional message-options options 7))
  (define-enum-type
    field-descriptor-proto:type
    (type-double 1)
    (type-float 2)
    (type-int64 3)
    (type-uint64 4)

    (optional string name 1)
    (optional int32 number 3)
    (optional field-descriptor-proto:label label 4)
    (optional field-descriptor-proto:type type 5)
    (optional string type-name 6)
    (optional string extendee 2)
    (optional string default-value 7)
    (optional int32 oneof-index 9)
    (optional field-options options 8))
  (define-message-type oneof-descriptor-proto (optional string name 1))
  (define-message-type
    enum-descriptor-proto
    (optional string name 1)
    (repeated enum-value-descriptor-proto value 2)
    (optional enum-options options 3))
  (define-message-type
    enum-value-descriptor-proto

    (lite-runtime 3))
  (define-message-type
    file-options
    (optional string java-package 1)
    (optional string java-outer-classname 8)
    (optional bool java-multiple-files 10 #f)
    (optional bool java-generate-equals-and-hash 20 #f)
    (optional bool java-string-check-utf8 27 #f)
    (optional file-options:optimize-mode optimize-for 9 'speed)
    (optional string go-package 11)
    (optional bool cc-generic-services 16 #f)
    (optional bool java-generic-services 17 #f)
    (optional bool py-generic-services 18 #f)
    (optional bool deprecated 23 #f)
    (repeated uninterpreted-option uninterpreted-option 999))
  (define-message-type
    message-options
    (optional bool message-set-wire-format 1 #f)
    (optional bool no-standard-descriptor-accessor 2 #f)
    (optional bool deprecated 3 #f)
    (repeated uninterpreted-option uninterpreted-option 999))
  (define-enum-type field-options:ctype (string 0) (cord 1) (string-piece 2))
  (define-message-type
    field-options
    (optional field-options:ctype ctype 1 'string)
    (optional bool packed 2)
    (optional bool lazy 5 #f)
    (optional bool deprecated 3 #f)
    (optional string experimental-map-key 9)
    (optional bool weak 10 #f)
    (repeated uninterpreted-option uninterpreted-option 999))
  (define-message-type
    enum-options
    (optional bool allow-alias 2)
    (optional bool deprecated 3 #f)
    (repeated uninterpreted-option uninterpreted-option 999))
  (define-message-type
    enum-value-options
    (optional bool deprecated 1 #f)
    (repeated uninterpreted-option uninterpreted-option 999))
  (define-message-type
    service-options
    (optional bool deprecated 33 #f)
    (repeated uninterpreted-option uninterpreted-option 999))
  (define-message-type
    method-options
    (optional bool deprecated 33 #f)
    (repeated uninterpreted-option uninterpreted-option 999))
  (define-message-type
    uninterpreted-option:name-part
    (required string name-part 1)
    (required bool is-extension 2))
  (define-message-type
    uninterpreted-option
    (repeated uninterpreted-option:name-part name 2)
    (optional string identifier-value 3)
    (optional uint64 positive-int-value 4)
    (optional int64 negative-int-value 5)
    (optional double double-value 6)
    (optional bytes string-value 7)
    (optional string aggregate-value 8))
  (define-message-type
    source-code-info:location
    (packed int32 path 1)
    (packed int32 span 2))
    (packed int32 span 2)
    (optional string leading-comments 3)
    (optional string trailing-comments 4))
  (define-message-type
    source-code-info
    (repeated source-code-info:location location 1)))

;; -*- 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 ((appender accessor mutator) msg v)
  (mutator
   msg
   (if (list? v)
       (foldl (flip cons) (accessor msg '()) v)
  (mutator msg (append (accessor msg '()) (if (list? v) v (list v)))))
       (cons v (accessor msg '()) ))))

(define (deserialize type #!optional [port (current-input-port)])
  (let ([info (prop:protobuf #f type)])
    (letrec ([msg ((message-info-constructor info))]
             [fields (message-info-fields info)]
             [required (hash-table-copy (message-info-required info))]
             [unknown (open-output-string)])
      (let loop ()
        (let-values ([(tag type) (read-tag/type port)])
          (unless (or (eof-object? tag) (eof-object? type))
            (hash-table-delete! required tag)
            (cond
              [(hash-table-ref/default fields tag #f)
               => (lambda (field)
		    (let* ([ftype (field-info-type field)]
			   [repeated? (field-info-repeated? field)]
			   [accessor (field-info-accessor field)]
			   [mutator (field-info-mutator field)]
			   [updator
			    (if repeated?
				(appender accessor mutator)
				mutator)])
		      (cond
		       [(primitive-info? ftype)
			(let ([ptype (primitive-info-type ftype)]
			      [read (primitive-info-reader ftype)])
			  (updator
			   msg
			   (cond
			    [(eq? type ptype)
			     (read port)]
			    [(and repeated? (eq? type 'sized) (not (eq? ptype 'sized)))
			     (read-sized (cut read-file <> read) port)]
			    [else
			     (syntax-error 'deserialize "wire type does not match declared type" type)])))]
		       [(enum-info? ftype)
			(let ([integer->enum (enum-info-integer->enum ftype)])
			  (updator
			   msg
			   (cond
			    [(eq? type 'int*)
			     (integer->enum (read-int* port))]
			    [(and repeated? (eq? type 'sized))
			     (map integer->enum
				  (read-sized (cut read-file <> read-int*) port))]
			    [else
			     (syntax-error 'deserialize "wire type does not match declared type" type)])))]
		       [(rtd? ftype)
			(updator
			 msg
			 (cond
			  [(eq? type 'sized)
			   (read-sized (cut deserialize ftype <>) port)]
			  [else
			   (syntax-error 'deserialize "wire type does not match declared type" type)]))])))]
                    (let* ([ftype (field-info-type field)]
                           [repeated? (field-info-repeated? field)]
                           [accessor (field-info-accessor field)]
                           [mutator (field-info-mutator field)]
                           [updator
                            (if repeated?
                                (appender accessor mutator)
                                mutator)])
                      (cond
                       [(primitive-info? ftype)
                        (let ([ptype (primitive-info-type ftype)]
                              [read (primitive-info-reader ftype)])
                          (updator
                           msg
                           (cond
                            [(eq? type ptype)
                             (read port)]
                            [(and repeated? (eq? type 'sized) (not (eq? ptype 'sized)))
                             (read-sized (cut read-list <> read) port)]
                            [else
                             (syntax-error 'deserialize "wire type does not match declared type" type)])))]
                       [(enum-info? ftype)
                        (let ([integer->enum (enum-info-integer->enum ftype)])
                          (updator
                           msg
                           (cond
                            [(eq? type 'int*)
                             (integer->enum (read-int* port))]
                            [(and repeated? (eq? type 'sized))
                             (map integer->enum
                                  (read-sized (cut read-list <> read-int*) port))]
                            [else
                             (syntax-error 'deserialize "wire type does not match declared type" type)])))]
                       [(rtd? ftype)
                        (updator
                         msg
                         (cond
                          [(eq? type 'sized)
                           (read-sized (cut deserialize ftype <>) port)]
                          [else
                           (syntax-error 'deserialize "wire type does not match declared type" type)]))])))]
              [else
               (write-tag/type tag type unknown)
               (case type
                 [(int*)
                  (write-uint* (read-uint* port) unknown)]
                 [(64bit)
                  (copy-port (make-limited-input-port port 8 #f) unknown)]
                 [(32bit)
                  (copy-port (make-limited-input-port port 4 #f) unknown)]
                 [(sized)
                  (let ([size (read-uint* port)])
                    (write-uint* size unknown)
                    (copy-port (make-limited-input-port port size #f) unknown))])])
            (loop))))
      (message-unknown-set! msg (get-output-string unknown))
      (unless (zero? (hash-table-size required))
        (syntax-error 'deserialize "missing required fields" (hash-table-keys required)))
      (for-each (lambda (field)
		  (let [(content ((field-info-accessor field) msg))]
		    (when (and (field-info-repeated? field) (list? content))
		      ((field-info-mutator field) msg (reverse content))))) (hash-table-values fields))
      msg)))

(define (serialize msg #!optional [port (current-output-port)])
  (let ([info (prop:protobuf msg)])
    (let ([fields (message-info-fields info)]
          [required (hash-table-copy (message-info-required info))])
      (hash-table-walk
       fields
       (lambda (tag field)
	 (let ([vs ((field-info-accessor field) msg void)])
	   (unless (eq? vs (void))
	     (let ([repeated? (field-info-repeated? field)]
		   [packed? (field-info-packed? field)])
	       (for-each
		(lambda (v)
		  (hash-table-delete! required tag)
		  (let ([ftype (field-info-type field)])
		    (cond
		     [(primitive-info? ftype)
		      (let ([ptype (primitive-info-type ftype)]
			    [write (primitive-info-writer ftype)])
			(cond
			 [(and repeated? packed?)
			  (when (eq? ptype 'sized)
			    (error 'serialize "cannot apply packed encoding to sized type"))
			  (write-tag/type tag 'sized port)
			  (write-sized
			   (cut for-each write <> <>) vs port)]
			 [else
			  (write-tag/type tag ptype port)
			  (write v port)]))]
		     [(enum-info? ftype)
		      (let ([enum->integer (enum-info-enum->integer ftype)])
			(cond
			 [(and repeated? packed?)
			  (write-tag/type tag 'sized port)
			  (write-sized
			   (cut for-each write-int* <> <>) (map enum->integer vs) port)]
			 [else
			  (write-tag/type tag 'int* port)
			  (write-int* (enum->integer v) port)]))]
		     [else
		      (write-tag/type tag 'sized port)
		      (write-sized serialize v port)])))
		(if (and repeated? (not packed?)) vs (list vs))))))))
         (let ([vs ((field-info-accessor field) msg void)])
           (unless (eq? vs (void))
             (let ([repeated? (field-info-repeated? field)]
                   [packed? (field-info-packed? field)])
               (for-each
                (lambda (v)
                  (hash-table-delete! required tag)
                  (let ([ftype (field-info-type field)])
                    (cond
                     [(primitive-info? ftype)
                      (let ([ptype (primitive-info-type ftype)]
                            [write (primitive-info-writer ftype)])
                        (cond
                         [(and repeated? packed?)
                          (when (eq? ptype 'sized)
                            (error 'serialize "cannot apply packed encoding to sized type"))
                          (write-tag/type tag 'sized port)
                          (write-sized
                           (lambda (v p)
			     (for-each (cut write <> p) v)) vs port)]
                         [else
                          (write-tag/type tag ptype port)
                          (write v port)]))]
                     [(enum-info? ftype)
                      (let ([enum->integer (enum-info-enum->integer ftype)])
                        (cond
                         [(and repeated? packed?)
                          (write-tag/type tag 'sized port)
                          (write-sized
                           (lambda (v p)
			     (for-each (cut write-int* <> p) v))
			   (map enum->integer vs) port)]
                         [else
                          (write-tag/type tag 'int* port)
                          (write-int* (enum->integer v) port)]))]
                     [else
                      (write-tag/type tag 'sized port)
                      (write-sized serialize v port)])))
                (if (and repeated? (not packed?)) vs (list vs))))))))
      (write-string (message-unknown msg) #f port)
      (unless (zero? (hash-table-size required))
        (syntax-error 'serialize "missing required fields" (hash-table-keys required))))))

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

((category data io)
 (synopsis "Protocol buffer serialization")
 (author "Thomas Chust")
 (license "BSD")
 (version "1.2.3")
 (dependencies
   srfi-13
   srfi-18
   srfi-42
   srfi-69
   srfi-99)
 (test-dependencies
   test)
 (components
   (extension protobuf
     (modules
       protobuf
       protobuf-encoding
       protobuf-reflection
       protobuf-syntax
       protobuf-generic)
     (source-dependencies
       "srfi-4-comprehensions.scm"
       "encoding.scm"
       "reflection.scm"
       "syntax.scm"
       "generic.scm"))
   (program protoc-gen-chicken
     (component-dependencies
       protobuf)
     (source-dependencies
       "google/protobuf/descriptor.scm"
       "extend/protobuf/bigint.scm"
       "google/protobuf/compiler/plugin.scm"
       "generator.scm"))
   (c-include extend/protobuf
     (files
       "extend/protobuf/bigint.proto"
       "extend/protobuf/chicken.proto"))))

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

;; -*- mode: Scheme; -*-
((category data io)
 (license "BSD")
 (author "Thomas Chust")
 (synopsis "Protocol buffer serialization")
 (doc-from-wiki)
 (needs srfi-42 srfi-4-comprehensions srfi-99 numbers)
 (test-depends srfi-78)
 (files
  "protobuf.scm"
  "encoding.scm" "reflection.scm" "syntax.scm" "main.scm"
  "protoc-gen-chicken.scm"
  "google/protobuf/descriptor.scm" "google/protobuf/compiler/plugin.scm"
  "extend/protobuf/bigint.proto" "extend/protobuf/bigint.scm"
  "extend/protobuf/chicken.proto"
  "generator.scm"
  "tests/run.scm"
  "tests/abook.proto" "tests/abook.scm"
  "tests/main.scm" "tests/generic.scm"))

(repo fossil "https://chust.org/repos/chicken-{egg-name}")

(uri targz "https://chust.org/repos/chicken-{egg-name}/tarball/{egg-name}.tar.gz?uuid=v{egg-release}")
(release "1.2.3")
(release "1.2.2")
(release "1.2.1")
(release "1.2.0")

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

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

(require-library
 srfi-4 srfi-13 srfi-18 srfi-42 srfi-4-comprehensions srfi-69 srfi-99
 ports extras
 numbers)
(module srfi-4-comprehensions
  *
  (import
    scheme
    (chicken base)
    (chicken fixnum)
    srfi-4 srfi-42)
  (include "srfi-4-comprehensions.scm"))

(module protobuf-encoding
  (make-limited-input-port
   read-uint* write-uint*
   read-sint* write-sint*
   read-int* write-int*
   read-bool write-bool
   read-fixed* read-fixed32 read-fixed64 read-sfixed32 read-sfixed64
   write-fixed* write-fixed32 write-fixed64 write-sfixed32 write-sfixed64
   read-float* read-float read-double
   write-float* write-float write-double
   read-sized-bytes write-sized-bytes
   read-sized-string write-sized-string
   read-sized write-sized
   read-tag/type write-tag/type)
  (import
   scheme chicken
   srfi-4 (only srfi-18 raise) srfi-42 srfi-4-comprehensions
   ports extras numbers)
    scheme
    (chicken base)
    (chicken fixnum)
    (chicken bitwise)
    (chicken io)
    (chicken port)
    (chicken syntax)
    srfi-4 srfi-4-comprehensions srfi-42
    (only srfi-18 raise))
  (include "encoding.scm"))

(module protobuf-reflection
  (type-info
   type-info?
   type-info-name
   primitive-info

   field-info-accessor field-info-mutator
   message
   message?
   message-extensions
   message-unknown message-unknown-set!
   prop:protobuf)
  (import
   scheme (except chicken define-record-type)
   srfi-69 srfi-99)
    scheme
    (chicken base)
    (chicken format)
    srfi-69 srfi-99)
  (include "reflection.scm"))

(module protobuf-syntax
  (int32 int64
   uint32 uint64 uint*
   sint32 sint64 sint*
   fixed32 fixed64
   sfixed32 sfixed64
   bool
   float double
   bytes string
   define-enum-type
   define-message-type
   define-message-extension)
  (import
   (except scheme string) (except chicken define-record-type)
   srfi-69 srfi-99
   protobuf-encoding protobuf-reflection)
    (except scheme string)
    (chicken base)
    srfi-69 srfi-99
    protobuf-encoding protobuf-reflection)
  (import-for-syntax
    (only (chicken string) conc)
    srfi-1)
  (include "syntax.scm"))

(module protobuf
  (serialize
   deserialize)
  (import
   scheme (except chicken define-record-type)
   srfi-69 srfi-99
    scheme
    (chicken base)
    (chicken io)
    (chicken port)
    (chicken syntax)
    (chicken module)
    srfi-69 srfi-99
   ports extras
   protobuf-encoding protobuf-reflection)
    protobuf-encoding protobuf-reflection)
  (reexport
   (only protobuf-reflection
	 message? message-extensions message-unknown))
     message? message-extensions message-unknown))
  (include "main.scm"))

(module protobuf-generic
  (current-serialization-context
   make-serialization-context serialization-context?
   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
    scheme
    (chicken base)
    (chicken fixnum)
    (chicken keyword)
    (chicken blob)
    (chicken port)
    (chicken syntax)
    (chicken foreign)
    (chicken memory representation)
    srfi-4 srfi-4-comprehensions srfi-13 srfi-42 srfi-69 srfi-99
   ports numbers lolevel
   protobuf-encoding)
    protobuf-encoding)
  (include "generic.scm"))

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

;; -*- mode: Scheme; -*-
(define -d*
  (cond-expand
   (debug '-d2)
   (else '-d1)))

(compile -s -O2 ,-d* "protobuf.scm" -J)
(compile -s -O2 -d0 "protobuf-encoding.import.scm")
(compile -s -O2 -d0 "protobuf-reflection.import.scm")
(compile -s -O2 -d0 "protobuf-syntax.import.scm")
(compile -s -O2 -d0 "protobuf.import.scm")
(compile -s -O2 -d0 "protobuf-generic.import.scm")

(install-extension
 '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.2")))

(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.2")))

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

(require-library
 srfi-1 srfi-13 srfi-69
 data-structures irregex files ports extras
 protobuf)
(import
  protobuf)

(include "google/protobuf/descriptor.scm")
(include "extend/protobuf/bigint.scm")
(include "google/protobuf/compiler/plugin.scm")

(module protobuf-generator
  (proto-file-register!
   proto-file-translate
   generate-chicken)
  (import
   scheme chicken
   srfi-1 srfi-13 srfi-69
    scheme
    (chicken base)
    (chicken irregex)
    (chicken condition)
    (chicken pathname)
    (chicken port)
    (chicken pretty-print)
    (only (chicken string) conc)
    srfi-1 srfi-13 srfi-69
   data-structures irregex files ports extras
   google-protobuf extend-protobuf google-protobuf-compiler)
    google-protobuf extend-protobuf google-protobuf-compiler)
  (include "generator.scm"))

(import
 protobuf google-protobuf-compiler protobuf-generator)
  google-protobuf-compiler protobuf-generator)

(serialize (generate-chicken (deserialize code-generator-request)))

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

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

  accessor mutator)

(define (field-info-type v)
  (force (field-info-type* v)))

(define-record-printer (message-info v port)
  (fprintf port "#<message-type: ~a ~s>"
	   (type-info-name v)
	   (hash-table-keys (message-info-fields v))))
           (type-info-name v)
           (hash-table-keys (message-info-fields v))))

(define-record-type (message #:uid 'protobuf:message)
  #f #t
  extensions
  (unknown))

(define-record-property prop:protobuf)

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

;; -*- mode: Scheme; -*-
;;
;; This file is part of Protocol Buffers for CHICKEN
;; Copyright (c) 2018 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-syntax u8vector-of-length-ec
  (syntax-rules ()
    [(u8vector-ec size args ... expr)
     (let ([v (make-u8vector size)] [i 0])
       (do-ec args ...
         (begin
           (u8vector-set! v i expr)
           (set! i (+ i 1))))
       v)]))

(define-syntax u8vector-ec
  (syntax-rules ()
    [(u8vector-ec args ...)
     (list->u8vector (list-ec args ...))]))

(define-syntax :u8vector
  (syntax-rules (index)
    [(:u8vector cc var (index i) arg)
     (:do cc
       (let ([v arg]))
       ([i 0])
       (fx< i (u8vector-length v))
       (let ([var (u8vector-ref v i)]))
       #t
       ((fx+ i 1)))]
    [(:u8vector cc var arg)
     (:u8vector cc var (index i) arg)]))

(define-syntax s8vector-of-length-ec
  (syntax-rules ()
    [(s8vector-ec size args ... expr)
     (let ([v (make-s8vector size)] [i 0])
       (do-ec args ...
         (begin
           (s8vector-set! v i expr)
           (set! i (+ i 1))))
       v)]))

(define-syntax s8vector-ec
  (syntax-rules ()
    [(s8vector-ec args ...)
     (list->s8vector (list-ec args ...))]))

(define-syntax :s8vector
  (syntax-rules (index)
    [(:s8vector cc var (index i) arg)
     (:do cc
       (let ([v arg]))
       ([i 0])
       (fx< i (s8vector-length v))
       (let ([var (s8vector-ref v i)]))
       #t
       ((fx+ i 1)))]
    [(:s8vector cc var arg)
     (:s8vector cc var (index i) arg)]))

(define-syntax u16vector-of-length-ec
  (syntax-rules ()
    [(u16vector-ec size args ... expr)
     (let ([v (make-u16vector size)] [i 0])
       (do-ec args ...
         (begin
           (u16vector-set! v i expr)
           (set! i (+ i 1))))
       v)]))

(define-syntax u16vector-ec
  (syntax-rules ()
    [(u16vector-ec args ...)
     (list->u16vector (list-ec args ...))]))

(define-syntax :u16vector
  (syntax-rules (index)
    [(:u16vector cc var (index i) arg)
     (:do cc
       (let ([v arg]))
       ([i 0])
       (fx< i (u16vector-length v))
       (let ([var (u16vector-ref v i)]))
       #t
       ((fx+ i 1)))]
    [(:u16vector cc var arg)
     (:u16vector cc var (index i) arg)]))

(define-syntax s16vector-of-length-ec
  (syntax-rules ()
    [(s16vector-ec size args ... expr)
     (let ([v (make-s16vector size)] [i 0])
       (do-ec args ...
         (begin
           (s16vector-set! v i expr)
           (set! i (+ i 1))))
       v)]))

(define-syntax s16vector-ec
  (syntax-rules ()
    [(s16vector-ec args ...)
     (list->s16vector (list-ec args ...))]))

(define-syntax :s16vector
  (syntax-rules (index)
    [(:s16vector cc var (index i) arg)
     (:do cc
       (let ([v arg]))
       ([i 0])
       (fx< i (s16vector-length v))
       (let ([var (s16vector-ref v i)]))
       #t
       ((fx+ i 1)))]
    [(:s16vector cc var arg)
     (:s16vector cc var (index i) arg)]))

(define-syntax u32vector-of-length-ec
  (syntax-rules ()
    [(u32vector-ec size args ... expr)
     (let ([v (make-u32vector size)] [i 0])
       (do-ec args ...
         (begin
           (u32vector-set! v i expr)
           (set! i (+ i 1))))
       v)]))

(define-syntax u32vector-ec
  (syntax-rules ()
    [(u32vector-ec args ...)
     (list->u32vector (list-ec args ...))]))

(define-syntax :u32vector
  (syntax-rules (index)
    [(:u32vector cc var (index i) arg)
     (:do cc
       (let ([v arg]))
       ([i 0])
       (fx< i (u32vector-length v))
       (let ([var (u32vector-ref v i)]))
       #t
       ((fx+ i 1)))]
    [(:u32vector cc var arg)
     (:u32vector cc var (index i) arg)]))

(define-syntax s32vector-of-length-ec
  (syntax-rules ()
    [(s32vector-ec size args ... expr)
     (let ([v (make-s32vector size)] [i 0])
       (do-ec args ...
         (begin
           (s32vector-set! v i expr)
           (set! i (+ i 1))))
       v)]))

(define-syntax s32vector-ec
  (syntax-rules ()
    [(s32vector-ec args ...)
     (list->s32vector (list-ec args ...))]))

(define-syntax :s32vector
  (syntax-rules (index)
    [(:s32vector cc var (index i) arg)
     (:do cc
       (let ([v arg]))
       ([i 0])
       (fx< i (s32vector-length v))
       (let ([var (s32vector-ref v i)]))
       #t
       ((fx+ i 1)))]
    [(:s32vector cc var arg)
     (:s32vector cc var (index i) arg)]))

(define-syntax u64vector-of-length-ec
  (syntax-rules ()
    [(u64vector-ec size args ... expr)
     (let ([v (make-u64vector size)] [i 0])
       (do-ec args ...
         (begin
           (u64vector-set! v i expr)
           (set! i (+ i 1))))
       v)]))

(define-syntax u64vector-ec
  (syntax-rules ()
    [(u64vector-ec args ...)
     (list->u64vector (list-ec args ...))]))

(define-syntax :u64vector
  (syntax-rules (index)
    [(:u64vector cc var (index i) arg)
     (:do cc
       (let ([v arg]))
       ([i 0])
       (fx< i (u64vector-length v))
       (let ([var (u64vector-ref v i)]))
       #t
       ((fx+ i 1)))]
    [(:u64vector cc var arg)
     (:u64vector cc var (index i) arg)]))

(define-syntax s64vector-of-length-ec
  (syntax-rules ()
    [(s64vector-ec size args ... expr)
     (let ([v (make-s64vector size)] [i 0])
       (do-ec args ...
         (begin
           (s64vector-set! v i expr)
           (set! i (+ i 1))))
       v)]))

(define-syntax s64vector-ec
  (syntax-rules ()
    [(s64vector-ec args ... expr)
     (blob->s64vector/shared
      (u64vector->blob/shared
       (list->u64vector (list-ec args ... (modulo expr #x10000000000000000)))))]))

(define-syntax :s64vector
  (syntax-rules (index)
    [(:s64vector cc var (index i) arg)
     (:do cc
       (let ([v arg]))
       ([i 0])
       (fx< i (s64vector-length v))
       (let ([var (s64vector-ref v i)]))
       #t
       ((fx+ i 1)))]
    [(:s64vector cc var arg)
     (:s64vector cc var (index i) arg)]))

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

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

(define-syntax define-enum-type
  (syntax-rules ()
    [(define-enum-type name
       (alt tag)
       ...)
     (define name
       (make-enum-info
	'name
	(lambda (int)
	  (case int
	    [(tag) 'alt]
	    ...
	    [else (syntax-error 'name "unknown enumeration tag" int)]))
	(lambda (sym)
	  (case sym
	    [(alt) tag]
	    ...
	    [else (syntax-error 'name "unknown enumeration value" sym)]))))]))
        'name
        (lambda (int)
          (case int
            [(tag) 'alt]
            ...
            [else (syntax-error 'name "unknown enumeration tag" int)]))
        (lambda (sym)
          (case sym
            [(alt) tag]
            ...
            [else (syntax-error 'name "unknown enumeration value" sym)]))))]))

(define-syntax %message-field-label
  (syntax-rules (required optional repeated packed)
    ;;                               packed? -------\
    ;;                             repeated? ----\  |
    ;;                             required? -\  |  |
    ;;                                        |  |  |

  (er-macro-transformer
   (lambda (stx rename compare)
     (cons*
      (rename 'define-values)
      (map
       string->symbol
       (list (conc "make-" (cadr stx))
	     (conc (cadr stx) "?")))
             (conc (cadr stx) "?")))
      (cddr stx)))))

(define-syntax %define-message-accessor+mutator
  (er-macro-transformer
   (lambda (stx rename compare)
     (cons*
      (rename 'define-values)
      (map
       string->symbol
       (list (conc (cadr stx) "-" (caddr stx))
	     (conc (cadr stx) "-" (caddr stx) "-set!")))
             (conc (cadr stx) "-" (caddr stx) "-set!")))
      (cdddr stx)))))

(define-syntax define-message-type
  (syntax-rules ()
    [(define-message-type name
       (label type field tag . default)
       ...)
     (begin
       (define name
	 (letrec ([name
		   (make-rtd
		    'name '#((mutable field) ...)
		    #:parent message
		    #:property prop:protobuf (lambda _ descriptor))]
		  [descriptor
		   (void)])
	   (set! descriptor
	     (make-message-info
	      'name
	      (let ([constructor* (rtd-constructor name)])
		(lambda (#!key [field ((%message-field-default . default))] ...)
		  (constructor*
		   (make-hash-table eqv? eqv?-hash) ""
		   field ...)))
	      (make-hash-table eqv? eqv?-hash)
	      (make-hash-table eqv? eqv?-hash)))
	   (let-values ([(required? repeated? packed?)
			 (%message-field-label label)]
			[(accessor mutator)
			 (values
			  (let ([accessor* (rtd-accessor name 'field)])
			    (lambda (msg #!optional [v* (%message-field-default . default)])
			      (let ([v (accessor* msg)])
				(if (eq? v (void))
				    (if (procedure? v*) (v*) v*)
				    v))))
			  (rtd-mutator name 'field))])
	     (hash-table-set!
	      (message-info-fields descriptor) tag
	      (make-field-info
	       (delay type) repeated? packed?
	       (getter-with-setter accessor mutator) mutator))
	     (when required?
	       (hash-table-set!
		(message-info-required descriptor) tag
		#t)))
	   ...
	   name))
         (letrec ([name
                   (make-rtd
                    'name '#((mutable field) ...)
                    #:parent message
                    #:property prop:protobuf (lambda _ descriptor))]
                  [descriptor
                   (void)])
           (set! descriptor
             (make-message-info
              'name
              (let ([constructor* (rtd-constructor name)])
                (lambda (#!key [field ((%message-field-default . default))] ...)
                  (constructor*
                   (make-hash-table eqv? eqv?-hash) ""
                   field ...)))
              (make-hash-table eqv? eqv?-hash)
              (make-hash-table eqv? eqv?-hash)))
           (let-values ([(required? repeated? packed?)
                         (%message-field-label label)]
                        [(accessor mutator)
                         (values
                          (let ([accessor* (rtd-accessor name 'field)])
                            (lambda (msg #!optional [v* (%message-field-default . default)])
                              (let ([v (accessor* msg)])
                                (if (eq? v (void))
                                    (if (procedure? v*) (v*) v*)
                                    v))))
                          (rtd-mutator name 'field))])
             (hash-table-set!
              (message-info-fields descriptor) tag
              (make-field-info
               (delay type) repeated? packed?
               (getter-with-setter accessor mutator) mutator))
             (when required?
               (hash-table-set!
                (message-info-required descriptor) tag
                #t)))
           ...
           name))
       (%define-message-constructor+predicate name
         (values (message-info-constructor (prop:protobuf #f name))
		 (rtd-predicate name)))
                 (rtd-predicate name)))
       (%define-message-accessor+mutator name field
	 (let ([descriptor
		(hash-table-ref
		 (message-info-fields (prop:protobuf #f name)) tag)])
	   (values (field-info-accessor descriptor)
		   (field-info-mutator descriptor))))
         (let ([descriptor
                (hash-table-ref
                 (message-info-fields (prop:protobuf #f name)) tag)])
           (values (field-info-accessor descriptor)
                   (field-info-mutator descriptor))))
       ...)]))

(define-syntax define-message-extension
  (syntax-rules ()
    [(define-message-extension name
       (label type field tag . default)
       ...)
     (begin
       (let-values ([(descriptor)
		     (prop:protobuf #f name)]
		    [(required? repeated? packed?)
		     (%message-field-label label)]
		    [(accessor mutator)
		     (values
		      (lambda (msg #!optional [v* (%message-field-default . default)])
			(hash-table-ref
			 (message-extensions msg) tag v*))
		      (lambda (msg v)
			(hash-table-set!
			 (message-extensions msg) tag
			 v)))])
	 (hash-table-set!
	  (message-info-fields descriptor) tag
	  (make-field-info
	   (delay type) repeated? packed?
	   (getter-with-setter accessor mutator) mutator))
	 (when required?
	   (hash-table-set!
	    (message-info-required descriptor) tag
	    #t)))
                     (prop:protobuf #f name)]
                    [(required? repeated? packed?)
                     (%message-field-label label)]
                    [(accessor mutator)
                     (values
                      (lambda (msg #!optional [v* (%message-field-default . default)])
                        (hash-table-ref
                         (message-extensions msg) tag v*))
                      (lambda (msg v)
                        (hash-table-set!
                         (message-extensions msg) tag
                         v)))])
         (hash-table-set!
          (message-info-fields descriptor) tag
          (make-field-info
           (delay type) repeated? packed?
           (getter-with-setter accessor mutator) mutator))
         (when required?
           (hash-table-set!
            (message-info-required descriptor) tag
            #t)))
       ...
       (%define-message-accessor+mutator name field
	 (let ([descriptor
		(hash-table-ref
		 (message-info-fields (prop:protobuf #f name)) tag)])
	   (values (field-info-accessor descriptor)
		   (field-info-mutator descriptor))))
         (let ([descriptor
                (hash-table-ref
                 (message-info-fields (prop:protobuf #f name)) tag)])
           (values (field-info-accessor descriptor)
                   (field-info-mutator descriptor))))
       ...)]))

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

;; Generated by protoc-gen-chicken v1.0.0
;; Generated by protoc-gen-chicken v1.1.3
(module
  abook
  *
  (import (except scheme string) chicken protobuf-syntax)
  (import (except scheme string) (chicken base) protobuf-syntax)
  (define-enum-type person:phone-type (mobile 0) (home 1) (work 2))
  (define-message-type
    person:phone-number
    (required string number 1)
    (optional person:phone-type type 2 'home))
  (define-message-type
    person

;; -*- 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-record-type (foo
		     #:uid '4b9aa808-96ef-48e3-bb97-d71f37068fe1)
                     #:uid '4b9aa808-96ef-48e3-bb97-d71f37068fe1)
  #t #t
  a b)

(define (read-bar port)
  (make-bar (read-string #f port)))

(define (write-bar v port)
  (write-string (bar-ref v) #f port))

(define-record-type (bar
		     #:property prop:serialization-info
		     (make-serialization-info read-bar write-bar))
                     #:property prop:serialization-info
                     (make-serialization-info read-bar write-bar))
  #t #t
  ref)

(define (serialize+deserialize v)
  (call-with-input-string
   (call-with-output-string (cut serialize v <>))
   deserialize))

(define (check-invariance v #!optional [test equal?])
  (check (serialize+deserialize v) (=> test) v))
(define (test-invariance v #!optional [compare equal?])
  (test-assert (format "~s" v) (compare v (serialize+deserialize v))))

(define (run)
  (check-invariance (void) eq?)
  (check-invariance '() eq?)
  (check-invariance #!eof eq?)
  (check-invariance #f eq?)
  (check-invariance #t eq?)
  (check-invariance #\x eq?)
  
  (check-invariance 42 eq?)
  (check-invariance 23.45 eqv?)
  
  (check-invariance 42+23i)
  (check-invariance 4/2+2/3i)
  (check-invariance 0+2.34i)
  (check-invariance 2.34+3.56i)
  
  (check-invariance "foo")
  (check-invariance 'blubb eq?)
  (check-invariance #:troet eq?)
  
  (let* ([sym0 (gensym 'blubb)]
	 [sym1 (serialize+deserialize sym0)])
    (check (symbol->string sym1) (=> equal?) (symbol->string sym0))
    (check (eq? sym1 sym0) => #f))
  
  (check-invariance (cons 1 2))
  (check-invariance '(a b 42))
  
  (let* ([lst0 (circular-list 1 2 3)]
	 [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"))
(define (mul42 x)
  (* x 42))

(define (test-generic)
  (test-group "generic serialization"

    (test-group "immediate objects"
      (test-invariance (void) eq?)
      (test-invariance '() eq?)
      (test-invariance #!eof eq?)
      (test-invariance #f eq?)
      (test-invariance #t eq?)
      (test-invariance #\x eq?))

    (test-group "numbers"
      (test-invariance 42 =)
      (test-invariance 23.45 =)

      (test-invariance 42+23i =)
      (test-invariance 4/2+2/3i =)
      (test-invariance 0+2.34i =)
      (test-invariance 2.34+3.56i =))

    (test-group "strings"
      (test-invariance "foo"))

    (test-group "symbols"
      (test-invariance 'blubb eq?)
      (test-invariance #:troet eq?)

      (let* ([sym0 (gensym 'blubb)]
             [sym1 (serialize+deserialize sym0)])
        (test "gensym naming" (symbol->string sym1) (symbol->string sym0))
        (test-assert "gensym identity" (not (eq? sym1 sym0)))))

    (test-group "lists"
      (test-invariance (cons 1 2))
      (test-invariance '(a b 42))

      (let* ([lst0 (circular-list 1 2 3)]
             [lst1 (serialize+deserialize lst0)])
        (test-assert (eq? (cdddr lst1) lst1))
        (test (car lst0) (car lst1))
        (test (cadr lst0) (cadr lst1))
        (test (caddr lst0) (caddr lst1))))

    (test-group "vectors"
      (test-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))
  (check-invariance '#u32(1 2 3))
  (check-invariance '#s32(-1 0 +1))
  (check-invariance '#f32(1.234 5.678))
  (check-invariance '#f64(1.234 5.678))
  (check-invariance '#${983729423476237887246302})
  
  (check-invariance (make-foo 42+23i "Hallo Welt!"))
  (check-invariance (make-bar "kawumm!")))
      (let ([vec0 (vector 'a 'b (void))])
        (vector-set! vec0 2 vec0)
        (let ([vec1 (serialize+deserialize vec0)])
          (test-assert (eq? (vector-ref vec1 2) vec1))
          (test (vector-ref vec0 0) (vector-ref vec1 0))
          (test (vector-ref vec0 1) (vector-ref vec1 1)))))

    (test-group "hash tables"
      (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))))])
        (test lst0 lst1))

      (let* ([lst0 '((3 . "boo") (55 . "hoo"))]
             [lst1 (sort
                    (hash-table->alist
                     (serialize+deserialize
                      (alist->hash-table lst0)))
                    (lambda (a b)
                      (< (car a) (car b))))])
        (test lst0 lst1)))

    (test-group "procedures"
      (test 84 ((serialize+deserialize mul42) 2)))

    (test-group "homogeneous blobs"
      (test-invariance '#u8(1 2 3))
      (test-invariance '#s8(-1 0 +1))
      (test-invariance '#u16(1 2 3))
      (test-invariance '#s16(-1 0 +1))
      (test-invariance '#u32(1 2 3))
      (test-invariance '#s32(-1 0 +1))
      (test-invariance '#u64(1 2 3))
      (test-invariance '#s64(-1 0 +1))
      (test-invariance '#f32(1.234 5.678))
      (test-invariance '#f64(1.234 5.678))
      (test-invariance '#${983729423476237887246302}))

    (test-group "records"
      (test-invariance (make-foo 42+23i "Hallo Welt!"))
      (test-invariance (make-bar "kawumm!")))
    
    ))

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

;; -*- 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 packed-fields-message-bytes #${0A0503010401051203010405})

(define (message-rtd? v)
  (and (rtd? v) (message-info? (prop:protobuf #f v))))

(define msg
  (make-address-book
   #:person

     #:phone
     (list
      (make-person:phone-number
       #:number "+67-876743724-8751751" #:type 'mobile)
      (make-person:phone-number
       #:number "+60-9848752576-987832" #:type 'work))))))

(define (check-structure msg)
  (check (message? msg) => #t)
  (check (address-book? msg) => #t)
(define (test-structure msg)
  (test-assert (message? msg))
  (test-assert (address-book? msg))

  (let ([persons (address-book-person msg '())])
    (check (length persons) => 2)
    (test 2 (length persons))
    (let ([jane (first persons)]
	  [joe (second persons)])
      (check (person? jane) => #t)
      (check (person-id jane) => 42)
      (check (person-name jane) => "Jane Doe")
      (check (person-email jane) => (void))
      (check (person-email jane "jane@example.com") => "jane@example.com")
          [joe (second persons)])
      (test-assert (person? jane))
      (test 42 (person-id jane))
      (test "Jane Doe" (person-name jane))
      (test (void) (person-email jane))
      (test "jane@example.com" (person-email jane "jane@example.com"))

      (let ([phones (person-phone jane)])
	(check (length phones) => 1)
	(let ([phone (car phones)])
	  (check (person:phone-number-number phone) => "+12-3456-7890")
	  (check (person:phone-number-type phone) => 'home)))
        (test 1 (length phones))
        (let ([phone (car phones)])
          (test "+12-3456-7890" (person:phone-number-number phone))
          (test 'home (person:phone-number-type phone))))

      (check (person? joe) => #t)
      (check (person-id joe) => 23)
      (check (person-name joe) => "Johannes Mustermann")
      (check (person-email joe) => "joe@example.com")
      (check (person-email joe "whatever@example.com") => "joe@example.com")
      (test-assert (person? joe))
      (test 23 (person-id joe))
      (test "Johannes Mustermann" (person-name joe))
      (test "joe@example.com" (person-email joe))
      (test "joe@example.com" (person-email joe "whatever@example.com"))

      (let ([phones (person-phone joe)])
	(check (length phones) => 2)
	(let ([phone (first phones)])
	  (check (person:phone-number-number phone) => "+67-876743724-8751751")
	  (check (person:phone-number-type phone) => 'mobile))
	(let ([phone (second phones)])
	  (check (person:phone-number-number phone) => "+60-9848752576-987832")
	  (check (person:phone-number-type phone) => 'work))))))
        (test 2 (length phones))
        (let ([phone (first phones)])
          (test "+67-876743724-8751751" (person:phone-number-number phone))
          (test 'mobile (person:phone-number-type phone)))
        (let ([phone (second phones)])
          (test "+60-9848752576-987832" (person:phone-number-number phone))
          (test 'work (person:phone-number-type phone)))))))

(define (run)
  (check (message-rtd? person) => #t)
  (check (enum-info? person:phone-type) => #t)
  (check (message-rtd? person:phone-number) => #t)
  (check (message-rtd? address-book) => #t)
  
  (check ((enum-info-integer->enum person:phone-type) 2) => 'work)
  (check ((enum-info-enum->integer person:phone-type) 'home) => 1)
  
  (check-structure msg)
  (check-structure
   (call-with-input-string
    (call-with-output-string (cut serialize msg <>))
    (cut deserialize address-book <>)))
  
  (set! (address-book-person msg) (cdr (address-book-person msg)))
  (check (person-id (car (address-book-person msg))) => 23))
(define (test-main)
  (test-group "protocol buffers"

    (test-group "reflection"
      (test-assert (message-rtd? person))
      (test-assert (enum-info? person:phone-type))
      (test-assert (message-rtd? person:phone-number))
      (test-assert (message-rtd? address-book))

      (test 'work ((enum-info-integer->enum person:phone-type) 2))
      (test 1 ((enum-info-enum->integer person:phone-type) 'home)))

    (test-group "original message"
      (test-structure msg))
    (test-group "roundtrip message"
      (test-structure
       (call-with-input-string
        (call-with-output-string (cut serialize msg <>))
        (cut deserialize address-book <>))))

    (test-group "modification"
      (set! (address-book-person msg) (cdr (address-book-person msg)))
      (test 23 (person-id (car (address-book-person msg)))))
    (test-group "reading message with packed fields"
      (let
	  ((message
	    (call-with-input-string
	     (blob->string packed-fields-message-bytes)
	     (cut deserialize packed-message <>))))
	(test '(3 1 4 1 5) (packed-message-nums message))
	(test
	 '(green brown grey)
	 (packed-message-ranked-bikeshed-preferences message))))

    (test-group "round-trip message with packed fields"
      (let* ((original
	     (make-packed-message
	      #:nums '(1 3 5 7 9)
	      #:ranked-bikeshed-preferences '(grey blue)))
	     (new (call-with-input-string
		   (call-with-output-string (cut serialize original <>))
		   (cut deserialize packed-message <>))))
	(test (packed-message-nums original) (packed-message-nums new))
	(test
	 (packed-message-ranked-bikeshed-preferences original)
	 (packed-message-ranked-bikeshed-preferences new))))

    ))

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

// This file is part of Protocol Buffers for CHICKEN
// Copyright (c) 2013 by Thomas Chust.  All rights reserved.
// Copyright (c) 2022 by Chris Brannon.  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.
package packing;

enum Color {
  RED = 0;
  GREEN = 1;
  BLUE = 2;
  ORANGE = 3;
  BROWN = 4;
  GREY = 5;
}

message PackedMessage {
  repeated uint64 nums = 1 [packed = true];
  repeated Color ranked_bikeshed_preferences = 2 [packed = true];
}

;; Generated by protoc-gen-chicken v1.1.3
(module
  packing
  *
  (import (except scheme string) (chicken base) protobuf-syntax)
  (define-enum-type
    color
    (red 0)
    (green 1)
    (blue 2)
    (orange 3)
    (brown 4)
    (grey 5))
  (define-message-type
    packed-message
    (packed uint64 nums 1)
    (packed color ranked-bikeshed-preferences 2)))

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

(require-library
 srfi-1 srfi-78 srfi-99
 data-structures ports extras
 protobuf)
(import
  protobuf test)

(include "abook.scm")
(include "packing.scm")

(module tests-main
  (run)
(module test-main
  (test-main)
  (import
   scheme (except chicken define-record-type)
   srfi-1 srfi-78 srfi-99
   scheme
   (chicken base)
   (chicken blob)
   (chicken port)
   srfi-1 srfi-99
   ports
   protobuf protobuf-reflection abook)
   protobuf protobuf-reflection abook packing test)
  (include "main.scm"))

(module tests-generic
  (run)
(module test-generic
  (test-generic)
  (import
   scheme (except chicken define-record-type)
   srfi-1 srfi-69 srfi-78 srfi-99
   scheme
   (chicken base)
   (chicken sort)
   (chicken io)
   (chicken port)
   (chicken format)
   srfi-1 srfi-69 srfi-99
   data-structures ports extras
   protobuf-generic)
   protobuf-generic test)
  (include "generic.scm"))

(import
 srfi-78
 (prefix tests-main main-)
 (prefix tests-generic generic-))
  test-main test-generic)

(main-run)
(generic-run)
(test-main)
(test-generic)

(test-exit)
(check-report)

(exit (if (check-passed? 90) 0 1))
;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;;