protobuf

Check-in [8e3da7a570]
Login

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

Overview
Comment:imported v1.1.1
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk | v1.1.1
Files: files | file ages | folders
SHA3-256: 8e3da7a57089db0fece86f436ff2ef5fd9c37dd8e03f1549ac4b2468911e5fbd
User & Date: murphy 2018-08-18 20:05:59
Context
2018-08-18
20:06
imported v1.1.2 Leaf check-in: 9caf73d2af user: murphy tags: trunk, v1.1.2
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
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to extend/protobuf/chicken.proto.

99
100
101
102
103
104
105
106




107
108
109
110
111
112
113
...
117
118
119
120
121
122
123
124


125
126
127
128
}

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

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







|
>
>
>
>







 







|
>
>




99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
...
121
122
123
124
125
126
127
128
129
130
131
132
133
134
}

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

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

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

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

Changes to generic.scm.

132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
...
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
...
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
...
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
...
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
...
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
	(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)
................................................................................
    (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)
................................................................................

  (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)))]
................................................................................
	  [(#!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)])
................................................................................
	 (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))]
................................................................................
	[(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))







<
<
<
<
<







 







|
>
>
>
>
>









<
<



|
>
>







 







>
|






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





<
<
<
<
<
<
<







 







|
|




|
>


|
>

<
>



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

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

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

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







 







|


|


|



|







 







|


|













>
>
>









>
|
132
133
134
135
136
137
138





139
140
141
142
143
144
145
...
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
...
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
...
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
...
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
...
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
	(write-tag/type 1 'sized port)
	(write-sized write-value (##sys#slot block i) port))))

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

  (define (write-hash-table v port)





    (let ([v (hash-table-equivalence-function v)])
      (unless (eq? v equal?)
        (write-tag/type 2 'sized port)
	(write-sized write-value v port)))
    (let ([v (hash-table-hash-function v)])
      (unless (eq? v equal?-hash)
        (write-tag/type 3 'sized port)
................................................................................
    (let ([v (hash-table-weak-values v)])
      (when v
	(write-tag/type 7 'int* port)
	(write-bool v port)))
    (let ([v (hash-table-initial v)])
      (when v
	(write-tag/type 8 'sized port)
	(write-sized write-value v port)))
    (hash-table-walk
     v
     (lambda (k v)
       (write-tag/type 1 'sized port)
       (write-sized write-pair (cons k v) port))))

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

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


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

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

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

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

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

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

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

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








  (define (read-real port)
    (let more ([v 1])
      (let-values ([(tag type) (read-tag/type port)])
	(case tag
	  [(1)
	   (ensure-type 'int* type "numerator")
	   (more (* v (read-sint* port #f)))]
................................................................................
	  [(#!eof)
	   (if id
	       (import-symbol id)
	       (syntax-error 'deserialize "missing symbol id"))]
	  [else
	   (syntax-error 'deserialize "unknown symbol part" tag)]))))

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

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



  (define ((read-block read-special make-block) port)
    (let more ([slots '()] [specials '()])
      (let-values ([(tag type) (read-tag/type port)])
	(case tag
	  [(1)
	   (ensure-type 'sized type "slot")

	   (more (cons (read-sized-string port) slots) specials)]
	  [(#!eof)

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

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

  (define read-vector*
    (read-block
     (lambda (tag type port)
       (syntax-error 'deserialize "unknown vector part" tag))
     (lambda (n slots)

       (vector-of-length-ec n (:list s slots) s))))

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

  (define read-hash-table*









    (read-block
     (lambda (tag type port)
       (case tag





	 [(2)
	  (ensure-type 'sized type "equality function")




	  (values #:test (read-sized-string port))]
	 [(3)
	  (ensure-type 'sized type "hash function")

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


	 [(4)
	  (ensure-type '64bit type "minimum load factor")


	  (values #:min-load (read-double port))]

	 [(5)
	  (ensure-type '64bit type "maximum load factor")


	  (values #:max-load (read-double port))]

	 [(6)
	  (ensure-type 'int* type "weak keys flag")


	  (values #:weak-keys (read-bool port))]

	 [(7)
	  (ensure-type 'int* type "weak values flag")


	  (values #:weak-values (read-bool port))]

	 [(8)
	  (ensure-type 'sized type "initial value")

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


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

  (define (decode-hash-table! v)
    (let ([slots
	   (if (hash-table-dummy? v)
	       (let* ([test
		       (cond
			[(hash-table-dummy-test v) => decode-value]
			[else equal?])]
		      [hash
		       (cond
			[(hash-table-dummy-hash v) => decode-value]
			[else equal?-hash])]
		      [min-load
		       (hash-table-dummy-min-load v)]
		      [max-load
		       (hash-table-dummy-max-load v)]
		      [weak-keys
		       (hash-table-dummy-weak-keys v)]
		      [weak-values
		       (hash-table-dummy-weak-values v)]
		      [initial
		       (cond
			[(hash-table-dummy-initial v) => decode-value]
			[else #f])]

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

  (define read-procedure*


    (read-block
     (lambda (tag type port)
       (case tag



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


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






	 (do-ec (:list s (index i) slots) (##sys#setslot v (fx+ i 1) s))
	 v))))

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

  (define read-custom*


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





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










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

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

  (define (read-value port)
    (let-values ([(tag type) (read-tag/type port)])
      (case tag
	[(1)
	 (ensure-type 'int* type "special value")
	 (let ([tag (read-int* port)])
................................................................................
	 (remember! (read-sized-string port))]
	[(7)
	 (ensure-type 'sized type "symbol")
	 (remember! (read-sized read-symbol port))]

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

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

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

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

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

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

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

Changes to protobuf.scm.

20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
...
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*
................................................................................
   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"))







|







 







|



20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
...
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-4 srfi-13 srfi-18 srfi-42 srfi-4-comprehensions srfi-69 srfi-99
 ports extras
 numbers)

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

Changes to protobuf.setup.

15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
..
30
31
32
33
34
35
36
37
 '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")))







|







 







|
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
..
30
31
32
33
34
35
36
37
 'protobuf
 '("protobuf.so"
   "protobuf-encoding.import.so"
   "protobuf-reflection.import.so"
   "protobuf-syntax.import.so"
   "protobuf.import.so"
   "protobuf-generic.import.so")
 '((version "1.1.1")))

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

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

Changes to tests/generic.scm.

80
81
82
83
84
85
86







87
88
89
90
91
92
93
94
95









96
97
98
99
100
101
102
	 [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))







>
>
>
>
>
>
>









>
>
>
>
>
>
>
>
>







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

Changes to tests/run.scm.

53
54
55
56
57
58
59
60
 (prefix tests-main main-)
 (prefix tests-generic generic-))

(main-run)
(generic-run)

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







|
53
54
55
56
57
58
59
60
 (prefix tests-main main-)
 (prefix tests-generic generic-))

(main-run)
(generic-run)

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