protobuf

Check-in [a07d1893c3]
Login

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

Overview
Comment:imported v1.1.0
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk | v1.1.0
Files: files | file ages | folders
SHA3-256:a07d1893c3579b51a0c5eb4c82dccdf85bbd588b00c501ba707d4864085ffcf2
User & Date: murphy 2018-08-18 20:05:34
Context
2018-08-18
20:05
imported v1.1.1 check-in: 8e3da7a570 user: murphy tags: trunk, v1.1.1
20:05
imported v1.1.0 check-in: a07d1893c3 user: murphy tags: trunk, v1.1.0
20:03
imported v1.0.1 check-in: 216ffb08b7 user: murphy tags: trunk, v1.0.1
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to encoding.scm.

175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
  (write-float* 8))

(define (read-sized-bytes #!optional [port (current-input-port)])
  (let ([size (read-uint* port)])
    (if (eof-object? size)
        size
        (let ([bstr (read-u8vector size port)])
          (if (or (eof-object? bstr) (< (string-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))








|







175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
  (write-float* 8))

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

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

Added extend/protobuf/chicken.proto.

































































































































































































































































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

import "extend/protobuf/bigint.proto";

// Generic value container. To allow streaming, exactly a single
// field must be set.
message Value {
  enum Special {
    VOID = 1;
    NULL = 2;
    EOF = 3;
    FALSE = 4;
    TRUE = 5;
  }

  optional Special special = 1;
  optional uint32 char = 2;
  optional sint64 fixnum = 3;

  optional Complex number = 5;
  optional string string = 6;
  optional Symbol symbol = 7;

  optional Pair pair = 8;
  optional Vector vector = 9;
  optional HashTable hash_table = 10;

  optional Procedure procedure = 11;
  optional string lambda_info = 12;

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

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

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

// Arbitrary precision complex numeric value.
message Complex {
  optional Real real = 1;
  optional Real imag = 2;
}

// Symbol or keyword.
message Symbol {
  enum Type {
    INTERNED = 1;
    UNINTERNED = 2;
    KEYWORD = 3;
  }

  required string id = 1;
  optional Type type = 2 [default = INTERNED];
}

// Pair of values.
message Pair {
  required Value car = 1;
  required Value cdr = 2;
}

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

// Associative array of generic keys and values.
message HashTable {
  repeated Pair slot = 1;
  optional Value test = 2; // default = equal?
  optional Value hash = 3; // default = equal?-hash
  optional double min_load = 4 [default = 0.5];
  optional double max_load = 5 [default = 0.8];
  optional bool weak_keys = 6 [default = false]; // for future extensions
  optional bool weak_values = 7 [default = false]; // for future extensions
  optional Value initial = 8; // default = #f
}

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

// Custom serialized value.
message Custom {
  required bytes data = 1;
  optional Value reader = 2;
}

Added 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
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
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
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
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
308
309
310
311
312
313
314
315
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
437
438
439
440
441
442
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
;; -*- mode: Scheme; -*-
;;
;; This file is part of Protocol Buffers for CHICKEN
;; Copyright (c) 2013 by Thomas Chust.  All rights reserved.
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the Software), to deal in the Software without restriction,
;; including without limitation the rights to use, copy, modify,
;; merge, publish, distribute, sublicense, and/or sell copies of the
;; Software, and to permit persons to whom the Software is furnished
;; to do so, subject to the following conditions:
;; 
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; 
;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

(define-record-type (serialization-context
		     #:uid 'protobuf:serialization-context
		     #:opaque #t #:sealed #t)
  #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 obj->ref)])
	  (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 %procedure-id-set!
  (foreign-lambda* bool ([scheme-object proc] [c-string id])
    "void *addr = C_lookup_procedure_ptr(id);"
    "if (addr) {"
    "  C_set_block_item(proc, 0, (C_word) addr);"
    "  C_vector_to_closure(proc);"
    "  C_return(1);"
    "} else {"
    "  C_return(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-int* 2 port)]
     [(keyword? v)
      (write-tag/type 2 'int* port)
      (write-int* 3 port)]))

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

  (define ((write-block i0) block port)
    (do-ec (:range i i0 (##sys#size block))
      (begin
	(write-tag/type 1 'sized port)
	(write-sized write-value (##sys#slot block i) port))))

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

  (define (write-hash-table v port)
    (hash-table-walk
     v
     (lambda (k v)
       (write-tag/type 1 'sized port)
       (write-sized write-pair (cons k 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))))

  (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)
    (write-tag/type 1 'sized port)
    (write-sized (serialization-info-writer 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))))

  (define (write-value v port)
    (cond
     [(eq? v (void))
      (write-tag/type 1 'int* port)
      (write-int* 1 port)]
     [(null? v)
      (write-tag/type 1 'int* port)
      (write-int* 2 port)]
     [(eof-object? v)
      (write-tag/type 1 'int* port)
      (write-int* 3 port)]
     [(eq? v #f)
      (write-tag/type 1 'int* port)
      (write-int* 4 port)]
     [(eq? v #t)
      (write-tag/type 1 'int* port)
      (write-int* 5 port)]
     [(char? v)
      (write-tag/type 2 '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)]
     [(symbol? v)
      (write-tag/type 7 'sized port)
      (write-sized write-symbol v port)]
     [(pair? v)
      (write-tag/type 8 'sized port)
      (write-sized write-pair v port)]
     [(vector? v)
      (write-tag/type 9 'sized port)
      (write-sized write-vector v port)]
     [(hash-table? v)
      (write-tag/type 10 'sized port)
      (write-sized write-hash-table v port)]

     [(procedure? v)
      (write-tag/type 11 'sized port)
      (write-sized write-procedure v port)]
     [(##core#inline "C_lambdainfop" v)
      (write-tag/type 12 'sized port)
      (write-sized-string (##sys#lambda-info->string v) port)]

     [(u8vector? v)
      (write-tag/type 16 'sized port)
      (write-sized-bytes 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
       (current-input-port) (current-output-port) (current-error-port))))
  (set! remember!
    (serialization-context-rememberer context))
  (write-value v port))

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

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

  (define-syntax remember/dummy!
    (syntax-rules ()
      [(remember/dummy! expr)
       (let ([v (remember! (make-record-instance 'dummy))])
	 (object-become! (list (cons v expr)))
	 v)]))

  (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 port)
    (let more ([kar #f] [kdr #f])
      (let-values ([(tag type) (read-tag/type port)])
	(case tag
	  [(1)
	   (ensure-type 'sized type "car")
	   (more (read-sized read-value port) kdr)]
	  [(2)
	   (ensure-type 'sized type "cdr")
	   (more kar (read-sized read-value port))]
	  [(#!eof)
	   (cons kar kdr)]
	  [else
	   (syntax-error 'deserialize "unknown pair part" tag)]))))

  (define read-vector
    (let ([read-slot
	   (lambda (port)
	     (let-values ([(tag type) (read-tag/type port)])
	       (case tag
		 [(1)
		  (ensure-type 'sized type "vector slot")
		  (read-sized read-value port)]
		 [(#!eof)
		  tag]
		 [else
		  (syntax-error 'deserialize "unknown vector part" tag)])))])
      (lambda (port)
	(vector-ec (:port v port read-slot) v))))

  (define (read-hash-table port)
    (let more ([slots '()]
	       [test equal?]
	       [hash equal?-hash]
	       [min-load 0.5]
	       [max-load 0.8]
	       [weak-keys #f]
	       [weak-values #f]
	       [initial #f])
      (let-values ([(tag type) (read-tag/type port)])
	(case tag
	  [(1)
	   (ensure-type 'sized type "hash table slot")
	   (more
	    (cons (read-sized read-pair port) slots)
	    test hash min-load max-load weak-keys weak-values initial)]
	  [(2)
	   (ensure-type 'sized type "equality function")
	   (more
	    slots
	    (read-sized read-value port)
	    hash min-load max-load weak-keys weak-values initial)]
	  [(3)
	   (ensure-type 'sized type "hash function")
	   (more
	    slots test
	    (read-sized read-value port)
	    min-load max-load weak-keys weak-values initial)]
	  [(4)
	   (ensure-type '64bit type "minimum load factor")
	   (more
	    slots test hash
	    (read-double port)
	    max-load weak-keys weak-values initial)]
	  [(5)
	   (ensure-type '64bit type "maximum load factor")
	   (more
	    slots test hash min-load
	    (read-double port)
	    weak-keys weak-values initial)]
	  [(6)
	   (ensure-type 'int* type "weak keys flag")
	   (more
	    slots test hash min-load max-load
	    (read-bool port)
	    weak-values initial)]
	  [(7)
	   (ensure-type 'int* type "weak values flag")
	   (more
	    slots test hash min-load max-load weak-keys
	    (read-bool port)
	    initial)]
	  [(8)
	   (ensure-type 'sized type "initial value")
	   (more
	    slots test hash min-load max-load weak-keys weak-values
	    (read-sized read-value port))]
	  [(#!eof)
	   (alist->hash-table slots
			      #:test test #:hash hash
			      #:min-load min-load
			      #:max-load max-load
			      #:weak-keys weak-keys
			      #:weak-values weak-values
			      #:initial initial)]
	  [else
	   (syntax-error 'deserialize "unknown hash table part" tag)]))))

  (define (read-procedure port)
    (let more ([id #f] [slots '()])
      (let-values ([(tag type) (read-tag/type port)])
	(case tag
	  [(1)
	   (ensure-type 'sized type "procedure slot")
	   (more id (cons (read-sized read-value port) slots))]
	  [(2)
	   (ensure-type 'sized type "procedure id")
	   (more (read-sized-string port) slots)]
	  [(#!eof)
	   (let ([proc
		  (##sys#allocate-vector (fx+ (length slots) 1) #f (void) #f)])
	     (unless (%procedure-id-set! proc id)
	       (syntax-error 'deserialize "invalid procedure id" id))
	     (do-ec (:parallel (:range i (fx- (##sys#size proc) 1) 0 -1)
			       (:list v slots))
	       (##sys#setslot proc i v))
	     proc)]
	  [else
	   (syntax-error 'deserialize "unknown procedure part" tag)]))))

  (define (read-custom port)
    (let more ([data ""] [reader read])
      (let-values ([(tag type) (read-tag/type port)])
	(case tag
	  [(1)
	   (ensure-type 'sized type "custom data")
	   (more (read-sized-string port) reader)]
	  [(2)
	   (ensure-type 'sized type "custom reader")
	   (more data (read-sized read-value port))]
	  [(#!eof)
	   (call-with-input-string data reader)]
	  [else
	   (syntax-error 'deserialize "unknown custom value part" tag)]))))

  (define (read-record port)
    (let more ([slots '()])
      (let-values ([(tag type) (read-tag/type port)])
	(case tag
	  [(1)
	   (ensure-type 'sized type "record slot")
	   (more (cons (read-sized read-value port) slots))]
	  [(#!eof)
	   (apply make-record-instance (reverse! slots))]
	  [else
	   (syntax-error 'deserialize "unknown record part" tag)]))))

  (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")
	 (remember/dummy! (read-sized read-pair port))]
	[(9)
	 (ensure-type 'sized type "vector")
	 (remember/dummy! (read-sized read-vector port))]
	[(10)
	 (ensure-type 'sized type "hash table")
	 (remember/dummy! (read-sized read-hash-table port))]

	[(11)
	 (ensure-type 'sized type "procedure")
	 (remember/dummy! (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")
	 (remember/dummy! (read-sized read-custom port))]
	[(14)
	 (ensure-type 'sized type "record")
	 (remember/dummy! (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)])))

  (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)))
  (read-value port))

Changes to protobuf.meta.

6
7
8
9
10
11
12
13
14

15
16
17

 (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" "extend/protobuf/bigint.scm"
  "google/protobuf/compiler/plugin.scm"

  "generator.scm"
  "tests/run.scm"
  "tests/abook.proto" "tests/abook.scm"))








|
|
>


|
>
6
7
8
9
10
11
12
13
14
15
16
17
18
19
 (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"))

Changes to protobuf.scm.

20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
..
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
...
105
106
107
108
109
110
111















;; 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-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-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
................................................................................
   srfi-69 srfi-99
   ports extras
   protobuf-encoding protobuf-reflection)
  (reexport
   (only protobuf-reflection
	 message? message-extensions message-unknown))
  (include "main.scm"))






















|







 







|
<







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
..
41
42
43
44
45
46
47
48

49
50
51
52
53
54
55
...
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
;; 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-4 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-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
................................................................................
   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-1 srfi-4 srfi-42 srfi-4-comprehensions srfi-69 srfi-99
   ports numbers lolevel
   protobuf-encoding)
  (include "generic.scm"))

Changes to 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
;; -*- mode: Scheme; -*-





(compile -s -O2 -d1 "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")


(install-extension
 'protobuf
 '("protobuf.so"
   "protobuf-encoding.import.so"
   "protobuf-reflection.import.so"
   "protobuf-syntax.import.so"
   "protobuf.import.so")

 '((version "1.0.1")))

(compile -O2 -d1 "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")))




 '((version "1.0.1")))

>
>
>
>
>
|




>







|
>
|

|







|
>
>
>
>
|
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.0")))

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

Changes to syntax.scm.

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
(define-primitive-type int64 int*
  read-int* write-int*)
(define-primitive-type uint32 int*
  read-uint* write-uint*)
(define-primitive-type uint64 int*
  read-uint* write-uint*)
(define (uint* max-size)
  (primitive-info
   'uint* 'int*
   (cut read-uint* <> max-size)
   (cut write-uint* <> <> max-size)))
(define-primitive-type sint32 int*
  read-sint* write-sint*)
(define-primitive-type sint64 int*
  read-sint* write-sint*)
(define (sint* max-size)
  (primitive-info
   'sint* 'int*
   (cut read-sint* <> max-size)
   (cut write-sint* <> <> max-size)))
(define-primitive-type fixed32 32bit
  read-fixed32 write-fixed32)
(define-primitive-type fixed64 64bit
  read-fixed64 write-fixed64)







|








|







35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
(define-primitive-type int64 int*
  read-int* write-int*)
(define-primitive-type uint32 int*
  read-uint* write-uint*)
(define-primitive-type uint64 int*
  read-uint* write-uint*)
(define (uint* max-size)
  (make-primitive-info
   'uint* 'int*
   (cut read-uint* <> max-size)
   (cut write-uint* <> <> max-size)))
(define-primitive-type sint32 int*
  read-sint* write-sint*)
(define-primitive-type sint64 int*
  read-sint* write-sint*)
(define (sint* max-size)
  (make-primitive-info
   'sint* 'int*
   (cut read-sint* <> max-size)
   (cut write-sint* <> <> max-size)))
(define-primitive-type fixed32 32bit
  read-fixed32 write-fixed32)
(define-primitive-type fixed64 64bit
  read-fixed64 write-fixed64)

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

(define-record-type (foo
		     #:uid '4b9aa808-96ef-48e3-bb97-d71f37068fe1)
  #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* ([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))
  
  (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!")))

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

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

(define msg
  (make-address-book
   #:person
   (list
    (make-person
     #:id 42 #:name "Jane Doe"
     #:phone
     (list
      (make-person:phone-number #:number "+12-3456-7890")))
    (make-person
     #:id 23 #:name "Johannes Mustermann" #:email "joe@example.com"
     #: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))

Changes to tests/run.scm.

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
;; 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-78 srfi-99 protobuf)




(include "abook.scm")







(import srfi-78 srfi-99 protobuf protobuf-reflection abook)

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

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

(define msg
  (make-address-book
   #:person
   (list
    (make-person
     #:id 42 #:name "Jane Doe"
     #:phone
     (list
      (make-person:phone-number #:number "+12-3456-7890")))
    (make-person
     #:id 23 #:name "Johannes Mustermann" #:email "joe@example.com"
     #: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))))))

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

(check-report)
(exit (if (check-passed? (+ 7 (* 2 21))) 0 1))







|
>
>
>
>


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

|
|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
<

<
<
<
>
>
>
>

<
<
<
<
<
<
<
<
<
>
>

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<

|
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
;; 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? 86) 0 1))