protobuf

Check-in [3b4b1696e6]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Ported the egg to CHICKEN 5
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | chicken-5
Files: files | file ages | folders
SHA3-256:3b4b1696e6e8fa1308c9fcf4757872927aa60944c653546c23ce48e247c42619
User & Date: murphy 2018-08-19 02:08:48
Context
2018-08-19
02:35
Fixed generic serialization problems check-in: 1bff86b4c4 user: murphy tags: chicken-5
02:08
Ported the egg to CHICKEN 5 check-in: 3b4b1696e6 user: murphy tags: chicken-5
2018-08-18
20:06
imported v1.1.2 Leaf check-in: 9caf73d2af user: murphy tags: trunk, v1.1.2
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to encoding.scm.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
..
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
..
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
...
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
...
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
...
234
235
236
237
238
239
240


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

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

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

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

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

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

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

................................................................................
(define ((read-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)))))))

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

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

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

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

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

(define ((write-float* size) x #!optional [port (current-output-port)])
................................................................................

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

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

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

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

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

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

................................................................................
    (arithmetic-shift tag 3)
    (case type
      [(int*) 0]
      [(64bit) 1]
      [(32bit) 5]
      [(sized) 2]))
   port))









|


|







 







|
|
|
|



|



|
|



|
|




|
|
|
|
|
|




|



|







 







|







 







|
|
|
|
|
|












|
|
|
|
|
|







 







|
|
|
|
|
|
|
|







 







|












|












|







 







>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
..
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
..
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
...
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
...
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
...
234
235
236
237
238
239
240
241
242
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the Software), to deal in the Software without restriction,
;; including without limitation the rights to use, copy, modify,
;; merge, publish, distribute, sublicense, and/or sell copies of the
;; Software, and to permit persons to whom the Software is furnished
;; to do so, subject to the following conditions:
;;
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;;
;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
................................................................................
;; SOFTWARE.

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

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

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

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

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

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

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

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

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

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

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

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

(define ((write-float* size) x #!optional [port (current-output-port)])
................................................................................

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

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

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

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

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

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

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

Changes to extend/protobuf/bigint.scm.

1
2
3
4

5



6
;; Generated by protoc-gen-chicken v1.0.0
(module
  extend-protobuf
  *

  (import (except scheme string) chicken protobuf-syntax google-protobuf)



  (define-message-extension field-options (optional uint32 max-size 76884 10)))
|



>
|
>
>
>

1
2
3
4
5
6
7
8
9
10
;; Generated by protoc-gen-chicken v1.1.3
(module
  extend-protobuf
  *
  (import
    (except scheme string)
    (chicken base)
    protobuf-syntax
    google-protobuf)
  (define-message-extension field-options (optional uint32 max-size 76884 10)))

Changes to generator.scm.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
..
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
...
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233


;; 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 '("._"))])
    (lambda (str #!optional prefix)
      (string->symbol
       (conc
	(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)])
      (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)])
      (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 '()))))
................................................................................
    (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)))])
      (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 '()))))))
  
  (define (translate-field field prefix)
    (let ([name (make-identifier (field-descriptor-proto-name field))]
	  [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)])
       (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)])
       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)])))))))
  
  (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 '()))
       (append-map
	(cut translate-message-definition <> name)
	(descriptor-proto-nested-type msg '()))
       (append-map
	translate-message-extension
	(descriptor-proto-extension msg '()))
       `((define-message-type ,name
	   ,@(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)))))
  
  (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)
       (newline port)
       (pretty-print
	`(module ,module
	   *
	   (import
	    (except scheme string) chicken 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 <>)))]))









|


|











|



|
|
|
|
|









|





|


|
|






|







 







|
|
|
|






|
|
|
|
|
|
|


|


|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|



|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|




|
|

|
|

|
|

|
|
|
|



|
|







 







|


|
|
|
|
|
|
|












|












>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
..
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
...
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
;; 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 '("._"))])
    (lambda (str #!optional prefix)
      (string->symbol
       (conc
        (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)])
      (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)])
      (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 '()))))
................................................................................
    (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)))])
      (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 '()))))))

  (define (translate-field field prefix)
    (let ([name (make-identifier (field-descriptor-proto-name field))]
          [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)])
       (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)])
       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)])))))))

  (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 '()))
       (append-map
        (cut translate-message-definition <> name)
        (descriptor-proto-nested-type msg '()))
       (append-map
        translate-message-extension
        (descriptor-proto-extension msg '()))
       `((define-message-type ,name
           ,@(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)))))

  (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.1.3" port)
       (newline port)
       (pretty-print
        `(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: ;;

Changes to generic.scm.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
..
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
...
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
...
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
...
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
...
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
...
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
...
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727


;; 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)
  #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))))

(define (serialization-context-rememberer context)
  (let ([obj->ref (serialization-context-obj->ref context)]
	[ref->obj (serialization-context-ref->obj context)])
    (lambda (v)
      (cond
       [(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]))))

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

(define-record-type (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))))

  (define (write-complex v port)
    (let ([real (real-part v)]
	  [imag (imag-part v)])
      (unless (zero? real)
	(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))))

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

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

  (define (write-hash-table v port)
    (let ([v (hash-table-equivalence-function v)])
      (unless (eq? v equal?)
        (write-tag/type 2 'sized port)
	(write-sized write-value v port)))
    (let ([v (hash-table-hash-function v)])
      (unless (eq? v equal?-hash)
        (write-tag/type 3 'sized port)
	(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)))
    (let ([v (hash-table-max-load v)])
      (unless (= v 0.8)
	(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)))
    (let ([v (hash-table-weak-values v)])
      (when v
	(write-tag/type 7 'int* port)
	(write-bool v port)))
    (let ([v (hash-table-initial v)])
      (when v
	(write-tag/type 8 'sized port)
	(write-sized write-value v port)))
    (hash-table-walk
     v
     (lambda (k v)
       (write-tag/type 1 'sized port)
       (write-sized write-pair (cons k v) port))))

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

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

  (define (write-value v port)
    (cond
     [(eq? v (void))
      (write-tag/type 1 'int* port)
................................................................................
      (write-int* (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))]

     [(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)]
................................................................................
     [(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)))
       v port)]
     [(s16vector? v)
      (write-tag/type 19 'sized port)
      (write-sized
       (lambda (block 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)))
       v port)]
     [(s32vector? v)
      (write-tag/type 21 'sized port)
      (write-sized
       (lambda (block port)
	 (do-ec (:s32vector v block) (write-sint* v port)))
       v port)]
     #;[(u64vector? v)
      (write-tag/type 22 'sized port)
      (write-sized
       (lambda (block port)
	 (do-ec (:u64vector v block) (write-uint* v port)))
       v port)]
     #;[(s64vector? v)
      (write-tag/type 23 'sized port)
      (write-sized
       (lambda (block 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))]
       [else
	(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))))

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

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

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

  (define (read-real port)
    (let more ([v 1])
      (let-values ([(tag type) (read-tag/type port)])
	(case tag
	  [(1)
	   (ensure-type 'int* type "numerator")
	   (more (* v (read-sint* port #f)))]
	  [(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)]))))

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

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

  (define ((read-block read-special make-block) port)
    (let more ([slots '()] [specials '()])
      (let-values ([(tag type) (read-tag/type port)])
	(case tag
	  [(1)
	   (ensure-type 'sized type "slot")
	   (more (cons (read-sized-string port) slots) specials)]
	  [(#!eof)
	   (let-values ([(slots length) (reverse!/length slots)])
	     (apply make-block length slots specials))]
	  [else
	   (let-values ([special (read-special tag type port)])
	     (more slots (append special specials)))]))))

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

  (define read-vector*
................................................................................
  (define decode-vector!
    (decode-block! 0))

  (define read-hash-table*
    (read-block
     (lambda (tag type port)
       (case tag
	 [(2)
	  (ensure-type 'sized type "equality function")
	  (values #:test (read-sized-string port))]
	 [(3)
	  (ensure-type 'sized type "hash function")
	  (values #:hash (read-sized-string port))]
	 [(4)
	  (ensure-type '64bit type "minimum load factor")
	  (values #:min-load (read-double port))]
	 [(5)
	  (ensure-type '64bit type "maximum load factor")
	  (values #:max-load (read-double port))]
	 [(6)
	  (ensure-type 'int* type "weak keys flag")
	  (values #:weak-keys (read-bool port))]
	 [(7)
	  (ensure-type 'int* type "weak values flag")
	  (values #:weak-values (read-bool port))]
	 [(8)
	  (ensure-type 'sized type "initial value")
	  (values #:initial (read-sized-string port))]
	 [else
	  (syntax-error 'deserialize "unknown hash table part" tag)]))
     (lambda (n slots #!key test hash [min-load 0.5] [max-load 0.8] weak-keys weak-values initial)
       (if (or test hash initial)
	   (make-hash-table-dummy
	    test hash min-load max-load weak-keys weak-values initial
	    n slots)
	   (alist->hash-table
	    (list (cons 'slots slots))
	    #:min-load min-load #:max-load max-load
	    #:weak-keys weak-keys #:weak-values weak-values
	    #:size n)))))

  (define (decode-hash-table! v)
    (let ([slots
	   (if (hash-table-dummy? v)
	       (let* ([test
		       (cond
			[(hash-table-dummy-test v) => decode-value]
			[else equal?])]
		      [hash
		       (cond
			[(hash-table-dummy-hash v) => decode-value]
			[else equal?-hash])]
		      [min-load
		       (hash-table-dummy-min-load v)]
		      [max-load
		       (hash-table-dummy-max-load v)]
		      [weak-keys
		       (hash-table-dummy-weak-keys v)]
		      [weak-values
		       (hash-table-dummy-weak-values v)]
		      [initial
		       (cond
			[(hash-table-dummy-initial v) => decode-value]
			[else #f])]
		      [size
		       (hash-table-dummy-size v)]
		      [slots
		       (hash-table-dummy-slots v)])
		 (object-become!
		  (list
		   (cons
		    v
		    (make-hash-table
		     #:test test #:hash hash
		     #:min-load min-load #:max-load max-load
		     #:weak-keys weak-keys #:weak-values weak-values
		     #:initial initial #:size size))))
		 slots)
	       (let ([slots (hash-table-ref v 'slots)])
		 (hash-table-delete! v 'slots)
		 slots))])
      (do-ec (:list s slots)
	(let ([k+v (call-with-input-string s (read-pair! (cons #f #f)))])
	  (hash-table-set! v (car k+v) (cdr k+v)))))
    v)

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

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

  (define read-custom*
    (read-block
     (lambda (tag type port)
       (case tag
	 [(2)
	  (ensure-type 'sized type "custom reader")
	  (read-sized-string port)]
	 [else
	  (syntax-error 'deserialize "unknown custom value part" tag)]))
     (lambda (n data #!optional reader)
       (make-custom-dummy (string-concatenate data) reader))))

  (define (decode-custom! v)
    (object-become!
     (list
      (cons
       v
       (call-with-input-string
	(custom-dummy-data v)
	(cond
	 [(custom-dummy-reader v) => decode-value]
	 [else read])))))
    v)

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

  (define (read-value port)
    (let-values ([(tag type) (read-tag/type port)])
      (case tag
	[(1)
	 (ensure-type 'int* type "special value")
	 (let ([tag (read-int* port)])
	   (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))]

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

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

	[(16)
	 (ensure-type 'sized type "u8vector")
	 (remember! (read-sized-bytes port))]
	[(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))))]

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

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

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









|


|










|
|











|
|
|
|
|
|
|



|

<
|
<
<
|
|
|
|





|







 







|
|
|
|
|
|
|
|
|
|
|



|

|
|

|
|







 







|
|








|



|


|
|


|
|


|
|


|
|


|
|









|
|
|




|
|







 







|
|







 







|





|





|





|





|





|







 







|
|
|

|
|







 







|
|
|
|


|







|










|
|
|
|
|
|
|
|
|
|
|
|
|
|




|
|
|
|
|
|
|
|
|
|
|




|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|




|
|
|
|
|
|
|
|
|
|
|
|
|




|
|
|
|
|
|
|
|
|
|







 







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


|
|
|
|
|
|
|
|



|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|






|
|
|
|
|


|
|
|
|








|
|
|
|
|









|
|
|
|








|
|
|




|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|

|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|











|
|


>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51

52


53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
..
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
...
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
...
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
...
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
...
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
...
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
...
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
;; 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)
  #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))))

(define (serialization-context-rememberer context)
  (let ([obj->ref (serialization-context-obj->ref context)]
        [ref->obj (serialization-context-ref->obj context)])
    (lambda (v)

      (or (hash-table-ref/default 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)
  #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))))

  (define (write-complex v port)
    (let ([real (real-part v)]
          [imag (imag-part v)])
      (unless (zero? real)
        (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))))

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

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

  (define (write-hash-table v port)
    (let ([v (hash-table-equivalence-function v)])
      (unless (eq? v equal?)
        (write-tag/type 2 'sized port)
        (write-sized write-value v port)))
    (let ([v (hash-table-hash-function v)])
      (unless (eq? v equal?-hash)
        (write-tag/type 3 'sized port)
        (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)))
    (let ([v (hash-table-max-load v)])
      (unless (= v 0.8)
        (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)))
    (let ([v (hash-table-weak-values v)])
      (when v
        (write-tag/type 7 'int* port)
        (write-bool v port)))
    (let ([v (hash-table-initial v)])
      (when v
        (write-tag/type 8 'sized port)
        (write-sized write-value v port)))
    (hash-table-walk
     v
     (lambda (k v)
       (write-tag/type 1 'sized port)
       (write-sized write-pair (cons k v) port))))

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

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

  (define (write-value v port)
    (cond
     [(eq? v (void))
      (write-tag/type 1 'int* port)
................................................................................
      (write-int* (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))]

     [(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)]
................................................................................
     [(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)))
       v port)]
     [(s16vector? v)
      (write-tag/type 19 'sized port)
      (write-sized
       (lambda (block 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)))
       v port)]
     [(s32vector? v)
      (write-tag/type 21 'sized port)
      (write-sized
       (lambda (block port)
         (do-ec (:s32vector v block) (write-sint* v port)))
       v port)]
     #;[(u64vector? v)
      (write-tag/type 22 'sized port)
      (write-sized
       (lambda (block port)
         (do-ec (:u64vector v block) (write-uint* v port)))
       v port)]
     #;[(s64vector? v)
      (write-tag/type 23 'sized port)
      (write-sized
       (lambda (block 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))]
       [else
        (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))))

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

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

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

  (define (read-real port)
    (let more ([v 1])
      (let-values ([(tag type) (read-tag/type port)])
        (case tag
          [(1)
           (ensure-type 'int* type "numerator")
           (more (* v (read-sint* port #f)))]
          [(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)]))))

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

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

  (define ((read-block read-special make-block) port)
    (let more ([slots '()] [specials '()])
      (let-values ([(tag type) (read-tag/type port)])
        (case tag
          [(1)
           (ensure-type 'sized type "slot")
           (more (cons (read-sized-string port) slots) specials)]
          [(#!eof)
           (let-values ([(slots length) (reverse!/length slots)])
             (apply make-block length slots specials))]
          [else
           (let-values ([special (read-special tag type port)])
             (more slots (append special specials)))]))))

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

  (define read-vector*
................................................................................
  (define decode-vector!
    (decode-block! 0))

  (define read-hash-table*
    (read-block
     (lambda (tag type port)
       (case tag
         [(2)
          (ensure-type 'sized type "equality function")
          (values #:test (read-sized-string port))]
         [(3)
          (ensure-type 'sized type "hash function")
          (values #:hash (read-sized-string port))]
         [(4)
          (ensure-type '64bit type "minimum load factor")
          (values #:min-load (read-double port))]
         [(5)
          (ensure-type '64bit type "maximum load factor")
          (values #:max-load (read-double port))]
         [(6)
          (ensure-type 'int* type "weak keys flag")
          (values #:weak-keys (read-bool port))]
         [(7)
          (ensure-type 'int* type "weak values flag")
          (values #:weak-values (read-bool port))]
         [(8)
          (ensure-type 'sized type "initial value")
          (values #:initial (read-sized-string port))]
         [else
          (syntax-error 'deserialize "unknown hash table part" tag)]))
     (lambda (n slots #!key test hash [min-load 0.5] [max-load 0.8] weak-keys weak-values initial)
       (if (or test hash initial)
           (make-hash-table-dummy
            test hash min-load max-load weak-keys weak-values initial
            n slots)
           (alist->hash-table
            (list (cons 'slots slots))
            #:min-load min-load #:max-load max-load
            #:weak-keys weak-keys #:weak-values weak-values
            #:size n)))))

  (define (decode-hash-table! v)
    (let ([slots
           (if (hash-table-dummy? v)
               (let* ([test
                       (cond
                        [(hash-table-dummy-test v) => decode-value]
                        [else equal?])]
                      [hash
                       (cond
                        [(hash-table-dummy-hash v) => decode-value]
                        [else equal?-hash])]
                      [min-load
                       (hash-table-dummy-min-load v)]
                      [max-load
                       (hash-table-dummy-max-load v)]
                      [weak-keys
                       (hash-table-dummy-weak-keys v)]
                      [weak-values
                       (hash-table-dummy-weak-values v)]
                      [initial
                       (cond
                        [(hash-table-dummy-initial v) => decode-value]
                        [else #f])]
                      [size
                       (hash-table-dummy-size v)]
                      [slots
                       (hash-table-dummy-slots v)])
                 (object-become!
                  (list
                   (cons
                    v
                    (make-hash-table
                     #:test test #:hash hash
                     #:min-load min-load #:max-load max-load
                     #:weak-keys weak-keys #:weak-values weak-values
                     #:initial initial #:size size))))
                 slots)
               (let ([slots (hash-table-ref v 'slots)])
                 (hash-table-delete! v 'slots)
                 slots))])
      (do-ec (:list s slots)
        (let ([k+v (call-with-input-string s (read-pair! (cons #f #f)))])
          (hash-table-set! v (car k+v) (cdr k+v)))))
    v)

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

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

  (define read-custom*
    (read-block
     (lambda (tag type port)
       (case tag
         [(2)
          (ensure-type 'sized type "custom reader")
          (read-sized-string port)]
         [else
          (syntax-error 'deserialize "unknown custom value part" tag)]))
     (lambda (n data #!optional reader)
       (make-custom-dummy (string-concatenate data) reader))))

  (define (decode-custom! v)
    (object-become!
     (list
      (cons
       v
       (call-with-input-string
        (custom-dummy-data v)
        (cond
         [(custom-dummy-reader v) => decode-value]
         [else read])))))
    v)

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

  (define (read-value port)
    (let-values ([(tag type) (read-tag/type port)])
      (case tag
        [(1)
         (ensure-type 'int* type "special value")
         (let ([tag (read-int* port)])
           (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))]

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

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

        [(16)
         (ensure-type 'sized type "u8vector")
         (remember! (read-sized-bytes port))]
        [(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))))]

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

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

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

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

Changes to google/protobuf/compiler/plugin.scm.

1
2
3
4

5



6
7
8
9
10
11
12
;; Generated by protoc-gen-chicken v1.0.0
(module
  google-protobuf-compiler
  *

  (import (except scheme string) chicken 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
|



>
|
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
;; Generated by protoc-gen-chicken v1.1.3
(module
  google-protobuf-compiler
  *
  (import
    (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

Changes to google/protobuf/descriptor.scm.

1
2
3
4
5
6
7
8
9
10
11
12
13


14
15
16
17
18
19
20
..
25
26
27
28
29
30
31

32
33
34
35
36
37
38
..
60
61
62
63
64
65
66

67

68
69
70
71
72
73
74
..
93
94
95
96
97
98
99

100

101
102
103

104
105
106
107
108

109
110
111
112
113
114

115
116

117
118
119


120
121
122

123
124
125

126
127
128

129
130
131
132
133
134
135
...
139
140
141
142
143
144
145
146


147
148
149
;; Generated by protoc-gen-chicken v1.0.0
(module
  google-protobuf
  *
  (import (except scheme string) chicken 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 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
    (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)

    (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 field-options options 8))

  (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 file-options:optimize-mode optimize-for 9 'speed)

    (optional bool cc-generic-services 16 #f)
    (optional bool java-generic-services 17 #f)
    (optional bool py-generic-services 18 #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)

    (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 deprecated 3 #f)
    (optional string experimental-map-key 9)

    (repeated uninterpreted-option uninterpreted-option 999))
  (define-message-type
    enum-options


    (repeated uninterpreted-option uninterpreted-option 999))
  (define-message-type
    enum-value-options

    (repeated uninterpreted-option uninterpreted-option 999))
  (define-message-type
    service-options

    (repeated uninterpreted-option uninterpreted-option 999))
  (define-message-type
    method-options

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


  (define-message-type
    source-code-info
    (repeated source-code-info:location location 1)))
|



|








>
>







 







>







 







>

>







 







>

>



>





>






>


>



>
>



>



>



>







 







|
>
>



1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
..
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
..
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
..
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
...
155
156
157
158
159
160
161
162
163
164
165
166
167
;; Generated by protoc-gen-chicken v1.1.3
(module
  google-protobuf
  *
  (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
    (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
................................................................................
    (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)
    (optional string leading-comments 3)
    (optional string trailing-comments 4))
  (define-message-type
    source-code-info
    (repeated source-code-info:location location 1)))

Changes to main.scm.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
...
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147


;; 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
................................................................................
      (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)]))])))]
              [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)]
................................................................................
(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))))))))
      (write-string (message-unknown msg) #f port)
      (unless (zero? (hash-table-size required))
        (syntax-error 'serialize "missing required fields" (hash-table-keys required))))))









|


|







 







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|







 







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|



>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
...
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
;; 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
................................................................................
      (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-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)]
................................................................................
(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))))))))
      (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: ;;

Name change from protobuf.meta to protobuf.egg.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19










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










|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
((category data io)
 (synopsis "Protocol buffer serialization")
 (author "Thomas Chust")
 (license "BSD")
 (version "1.1.3")
 (dependencies
   srfi-4
   srfi-13
   srfi-18
   srfi-42
   srfi-69
   srfi-99)
 (test-dependencies
   test)
 (components
   (extension protobuf
     (modules protobuf
              srfi-4-comprehensions
              protobuf-generic
              protobuf-reflection
              protobuf-syntax
              protobuf-encoding))
   (program protoc-gen-chicken
     (component-dependencies protobuf))
   (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: ;;

Changes to protobuf.scm.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27

28
29




30
31
32
33
34
35
36
..
39
40
41
42
43
44
45
46







47
48
49
50
51
52
53
54
55
..
70
71
72
73
74
75
76
77


78
79
80
81
82
83
84
85
..
87
88
89
90
91
92
93
94

95
96



97
98
99
100
101
102
103





104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121








122
123
124
125


;; 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 protobuf-encoding
  (make-limited-input-port
   read-uint* write-uint*
   read-sint* write-sint*
   read-int* write-int*
   read-bool write-bool
................................................................................
   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)
  (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)
  (include "reflection.scm"))

(module protobuf-syntax
  (int32 int64
   uint32 uint64 uint*
   sint32 sint64 sint*
   fixed32 fixed64
................................................................................
   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)



  (include "syntax.scm"))

(module protobuf
  (serialize
   deserialize)
  (import
   scheme (except chicken define-record-type)





   srfi-69 srfi-99
   ports extras
   protobuf-encoding protobuf-reflection)
  (reexport
   (only protobuf-reflection
	 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
   ports numbers lolevel
   protobuf-encoding)
  (include "generic.scm"))









|


|









<
|
>
|
|
>
>
>
>







 







|
>
>
>
>
>
>
>
|
<







 







|
>
>
|







 







|
>
|
|
>
>
>






|
>
>
>
>
>
|
<
|


|











|
>
>
>
>
>
>
>
>
|
<
|

>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
..
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58

59
60
61
62
63
64
65
..
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
..
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125

126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150

151
152
153
154
;; 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.


(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-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 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
    (chicken base)
    (chicken format)
    srfi-69 srfi-99)
  (include "reflection.scm"))

(module protobuf-syntax
  (int32 int64
   uint32 uint64 uint*
   sint32 sint64 sint*
   fixed32 fixed64
................................................................................
   bool
   float double
   bytes string
   define-enum-type
   define-message-type
   define-message-extension)
  (import
    (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
    (chicken base)
    (chicken io)
    (chicken port)
    (chicken syntax)
    (chicken module)
    srfi-69 srfi-99

    protobuf-encoding protobuf-reflection)
  (reexport
   (only protobuf-reflection
     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
    (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

    protobuf-encoding)
  (include "generic.scm"))

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

Deleted protobuf.setup.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
;; -*- 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")))
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































Changes to protoc-gen-chicken.scm.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40







41
42
43
44
45
46
47
48
49


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

(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
   data-structures irregex files ports extras
   google-protobuf extend-protobuf google-protobuf-compiler)
  (include "generator.scm"))

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

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









|


|









|
<
<
|










|
>
>
>
>
>
>
>
|
<
|



|


>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26


27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46

47
48
49
50
51
52
53
54
55
;; 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.

(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 base)
    (chicken irregex)
    (chicken condition)
    (chicken pathname)
    (chicken port)
    (chicken pretty-print)
    (only (chicken string) conc)
    srfi-1 srfi-13 srfi-69

    google-protobuf extend-protobuf google-protobuf-compiler)
  (include "generator.scm"))

(import
  google-protobuf-compiler protobuf-generator)

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

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

Changes to reflection.scm.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68


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

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

(define-record-property prop:protobuf)









|


|







 







|
|







>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
;; 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))))

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

Added srfi-4-comprehensions.scm.





































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
;; -*- 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)])
       (do-ec (:integers i) args ... (u8vector-set! v i expr)))]))

(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 u16vector-of-length-ec
  (syntax-rules ()
    [(u16vector-ec size args ... expr)
     (let ([v (make-u16vector size)])
       (do-ec (:integers i) args ... (u16vector-set! v i expr)))]))

(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)])
       (do-ec (:integers i) args ... (s16vector-set! v i expr)))]))

(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)])
       (do-ec (:integers i) args ... (u32vector-set! v i expr)))]))

(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)])
       (do-ec (:integers i) args ... (s32vector-set! v i expr)))]))

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

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

Changes to syntax.scm.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
...
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224


;; 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)]))))]))

(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) "?")))
      (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!")))
      (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))
       (%define-message-constructor+predicate name
         (values (message-info-constructor (prop:protobuf #f 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))))
       ...)]))

(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)))
       ...
       (%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))))
       ...)]))









|


|







 







|
|
|
|
|
|
|
|
|
|
|







 







|










|









|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


|

|
|
|
|
|









|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|


|
|
|
|
|

>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
...
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
;; 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)]))))]))

(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) "?")))
      (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!")))
      (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))
       (%define-message-constructor+predicate name
         (values (message-info-constructor (prop:protobuf #f 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))))
       ...)]))

(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)))
       ...
       (%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))))
       ...)]))

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

Changes to tests/abook.scm.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
;; Generated by protoc-gen-chicken v1.0.0
(module
  abook
  *
  (import (except scheme string) chicken 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
    (required string name 1)
    (required int32 id 2)
    (optional string email 3)
    (repeated person:phone-number phone 4))
  (define-message-type address-book (repeated person person 1)))
|



|












1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
;; Generated by protoc-gen-chicken v1.1.3
(module
  abook
  *
  (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
    (required string name 1)
    (required int32 id 2)
    (optional string email 3)
    (repeated person:phone-number phone 4))
  (define-message-type address-book (repeated person person 1)))

Changes to tests/generic.scm.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51






52
53
54
55
56
57
58

59
60
61
62
63
64
65
66

67


68
69
70
71
72
73
74
75

76
77
78
79
80
81
82
83
84
85

86
87
88
89
90
91
92
93
94

95
96
97
98
99
100
101
102

103
104
105
106
107
108
109
110
111

112

113
114

115
116
117
118
119
120
121
122
123
124

125
126




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

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











|


|










|










|
|








|
|

|
>
>
>
>
>
>
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
>
|
>
>
|
|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
>
|

|
|
|
|
|
|
|
>
|
|
|
|
|
|
|
<
>
|
|
|
|
|
|
|
|
<
>
|
>
|
|
>
|
|
|
|
|
|
|
|
|
|
>
|
|
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114

115
116
117
118
119
120
121
122
123

124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
;; 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)
  #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))
  #t #t
  ref)

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

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

(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)])
          (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 '#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: ;;

Changes to tests/main.scm.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82



83
84
85
86
87
88
89
90

91

92
93
94
95
96

97
98




;; 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
................................................................................
     #: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)

  (let ([persons (address-book-person msg '())])
    (check (length persons) => 2)
    (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")

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

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

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

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











|


|







 







|
|
|


|

|
|
|
|
|
|


|
|
|
|

|
|
|
|
|


|
|
|
|
|
|
|

|
>
>
>
|
|
|
|
|
|
|
|
>
|
>
|
|
|
|
|
>
|
|
>
>
>
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
..
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
;; 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
................................................................................
     #:phone
     (list
      (make-person:phone-number
       #:number "+67-876743724-8751751" #:type 'mobile)
      (make-person:phone-number
       #:number "+60-9848752576-987832" #:type 'work))))))

(define (test-structure msg)
  (test-assert (message? msg))
  (test-assert (address-book? msg))

  (let ([persons (address-book-person msg '())])
    (test 2 (length persons))
    (let ([jane (first persons)]
          [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)])
        (test 1 (length phones))
        (let ([phone (car phones)])
          (test "+12-3456-7890" (person:phone-number-number phone))
          (test 'home (person:phone-number-type phone))))

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

    ))

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

Changes to tests/run.scm.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36


37
38
39
40
41
42
43

44
45






46
47
48
49
50
51
52
53
54
55
56
57
58


59
60
;; 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)

(include "abook.scm")

(module tests-main
  (run)
  (import
   scheme (except chicken define-record-type)


   srfi-1 srfi-78 srfi-99
   ports
   protobuf protobuf-reflection abook)
  (include "main.scm"))

(module tests-generic
  (run)

  (import
   scheme (except chicken define-record-type)






   srfi-1 srfi-69 srfi-78 srfi-99
   data-structures ports extras
   protobuf-generic)
  (include "generic.scm"))

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

(main-run)
(generic-run)



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







|


|









|
<
<
|



|
|

|
>
>
|
<
|


|
<
>

<
>
>
>
>
>
>
|
<
|



|
<
<

|
|

>
>
|
<
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26


27
28
29
30
31
32
33
34
35
36
37

38
39
40
41

42
43

44
45
46
47
48
49
50

51
52
53
54
55


56
57
58
59
60
61
62

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

(import


  protobuf test)

(include "abook.scm")

(module test-main
  (test-main)
  (import
   scheme
   (chicken base)
   (chicken port)
   srfi-1 srfi-99

   protobuf protobuf-reflection abook test)
  (include "main.scm"))

(module test-generic

  (test-generic)
  (import

   scheme
   (chicken base)
   (chicken sort)
   (chicken io)
   (chicken port)
   (chicken format)
   srfi-1 srfi-69 srfi-99

   protobuf-generic test)
  (include "generic.scm"))

(import
  test-main test-generic)



(test-main)
(test-generic)

(test-exit)

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