Index: LICENSE.txt ================================================================== --- LICENSE.txt +++ LICENSE.txt @@ -1,6 +1,6 @@ -Copyright (C) 2011-2013 Thomas Chust . All rights reserved. +Copyright (C) 2011-2018 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, Index: encoding.scm ================================================================== --- encoding.scm +++ encoding.scm @@ -8,14 +8,14 @@ ;; 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 @@ -26,47 +26,47 @@ (define (make-limited-input-port in limit close-orig?) (make-input-port #;read (lambda () (if (fx> limit 0) - (begin - (set! limit (fx- limit 1)) - (read-char in)) - #!eof)) + (begin + (set! limit (fx- limit 1)) + (read-char in)) + #!eof)) #;ready? (lambda () (and (fx> limit 0) - (char-ready? in))) + (char-ready? in))) #;close (lambda () (if close-orig? - (close-input-port in) - (void))) + (close-input-port in) + (void))) #;peek (lambda () (if (fx> limit 0) - (peek-char in) - #!eof)))) + (peek-char in) + #!eof)))) (define (read-uint* #!optional [port (current-input-port)] [max-size 10]) (let loop ([span 0]) (if (and max-size (>= span max-size)) - (syntax-error 'read-uint* "maximum integer size exceeded" max-size) - (let ((b (read-byte port))) - (if (and (not (eof-object? b)) (bit-set? b 7)) - (+ (bitwise-and b #x7f) - (* 128 (loop (add1 span)))) - b))))) + (syntax-error 'read-uint* "maximum integer size exceeded" max-size) + (let ((b (read-byte port))) + (if (and (not (eof-object? b)) (bit->boolean b 7)) + (+ (bitwise-and b #x7f) + (* 128 (loop (add1 span)))) + b))))) (define (write-uint* n #!optional [port (current-output-port)] [max-size 10]) (let loop ([n n] [span 0]) (if (and max-size (>= span max-size)) - (syntax-error 'write-uint* "maximum integer size exceeded" max-size) + (syntax-error 'write-uint* "maximum integer size exceeded" max-size) (let*-values ([(r b) (quotient&remainder n 128)] [(last?) (zero? r)]) (write-byte (if last? b (bitwise-ior #x80 b)) port) - (unless last? (loop r (add1 span))))))) + (unless last? (loop r (add1 span))))))) (define (read-sint* #!optional [port (current-input-port)] [max-size 10]) (let ([z (read-uint* port max-size)]) (if (eof-object? z) z @@ -78,11 +78,11 @@ (write-uint* (if (negative? i) (- -1 2i) 2i) port max-size))) (define (read-int* #!optional [port (current-input-port)]) (let ([n (read-uint* port)]) (if (eof-object? n) - n + n (if (positive? (- n #x8000000000000000)) (- n #x10000000000000000) n)))) (define (write-int* i #!optional [port (current-output-port)]) @@ -100,16 +100,16 @@ (if (eof-object? bstr) bstr (let ([span (u8vector-length bstr)]) (if (< span size) (syntax-error 'read-fixed* "found truncated fixed integer bytes") - (let ([unsigned - (sum-ec (:u8vector b (index i) bstr) - (arithmetic-shift b (fx* i 8)))]) - (if (and signed? (bit-set? unsigned (fx- (fx* size 8) 1))) - (- unsigned (arithmetic-shift 1 (fx* size 8))) - unsigned))))))) + (let ([unsigned + (sum-ec (:u8vector b (index i) bstr) + (arithmetic-shift b (fx* i 8)))]) + (if (and signed? (bit->boolean unsigned (fx- (fx* size 8) 1))) + (- unsigned (arithmetic-shift 1 (fx* size 8))) + unsigned))))))) (define read-fixed32 (read-fixed* 4 #f)) (define read-fixed64 (read-fixed* 8 #f)) @@ -118,16 +118,16 @@ (define read-sfixed64 (read-fixed* 8 #t)) (define ((write-fixed* size signed?) n #!optional [port (current-output-port)]) (let* ([unsigned - (if (and signed? (negative? n)) - (+ (arithmetic-shift 1 (fx* size 8)) n) - n)] - [bstr - (u8vector-of-length-ec size (:range i size) - (bitwise-and (arithmetic-shift unsigned (fx* i -8)) #xff))]) + (if (and signed? (negative? n)) + (+ (arithmetic-shift 1 (fx* size 8)) n) + n)] + [bstr + (u8vector-of-length-ec size (:range i size) + (bitwise-and (arithmetic-shift unsigned (fx* i -8)) #xff))]) (write-u8vector bstr port))) (define write-fixed32 (write-fixed* 4 #f)) (define write-fixed64 @@ -141,18 +141,18 @@ (let ([bstr (read-u8vector size port)]) (if (eof-object? bstr) bstr (let ([span (u8vector-length bstr)]) (cond - ((< span size) - (syntax-error 'read-float* "found truncated fixed floating point bytes")) - ((= size 8) - (f64vector-ref (blob->f64vector/shared (u8vector->blob/shared bstr)) 0)) - ((= size 4) - (f32vector-ref (blob->f32vector/shared (u8vector->blob/shared bstr)) 0)) - (else - (error 'read-float* "only 64-bit and 32-bit floating point values are supported"))))))) + ((< span size) + (syntax-error 'read-float* "found truncated fixed floating point bytes")) + ((= size 8) + (f64vector-ref (blob->f64vector/shared (u8vector->blob/shared bstr)) 0)) + ((= size 4) + (f32vector-ref (blob->f32vector/shared (u8vector->blob/shared bstr)) 0)) + (else + (error 'read-float* "only 64-bit and 32-bit floating point values are supported"))))))) (define read-float (read-float* 4)) (define read-double (read-float* 8)) @@ -178,11 +178,11 @@ (let ([size (read-uint* port)]) (if (eof-object? size) size (let ([bstr (read-u8vector size port)]) (if (or (eof-object? bstr) (< (u8vector-length bstr) size)) - (syntax-error 'read-sized-bytes "found truncated bytes") + (syntax-error 'read-sized-bytes "found truncated bytes") bstr))))) (define (write-sized-bytes bstr #!optional [port (current-output-port)]) (write-uint* (u8vector-length bstr) port) (write-u8vector bstr port)) @@ -191,11 +191,11 @@ (let ([size (read-uint* port)]) (if (eof-object? size) size (let ([bstr (read-string size port)]) (if (or (eof-object? bstr) (< (string-length bstr) size)) - (syntax-error 'read-sized-string "found truncated bytes") + (syntax-error 'read-sized-string "found truncated bytes") bstr))))) (define (write-sized-string bstr #!optional [port (current-output-port)]) (write-uint* (string-length bstr) port) (write-string bstr #f port)) @@ -204,11 +204,11 @@ (let ([size (read-uint* port)]) (if (eof-object? size) size (let ([v (read (make-limited-input-port port size #f))]) (if (eof-object? v) - (syntax-error 'read-sized "found truncated data") + (syntax-error 'read-sized "found truncated data") v))))) (define (write-sized write v #!optional [port (current-output-port)]) (let ([bstr (call-with-output-string (cut write v <>))]) (write-uint* (string-length bstr) port) @@ -236,5 +236,7 @@ [(int*) 0] [(64bit) 1] [(32bit) 5] [(sized) 2])) port)) + +;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;; Index: extend/protobuf/bigint.scm ================================================================== --- extend/protobuf/bigint.scm +++ extend/protobuf/bigint.scm @@ -1,6 +1,10 @@ -;; Generated by protoc-gen-chicken v1.0.0 +;; Generated by protoc-gen-chicken v1.1.3 (module extend-protobuf * - (import (except scheme string) chicken protobuf-syntax google-protobuf) + (import + (except scheme string) + (chicken base) + protobuf-syntax + google-protobuf) (define-message-extension field-options (optional uint32 max-size 76884 10))) Index: extend/protobuf/chicken.proto ================================================================== --- extend/protobuf/chicken.proto +++ extend/protobuf/chicken.proto @@ -6,14 +6,14 @@ // 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 @@ -54,22 +54,22 @@ optional bytes s8vector = 17; repeated uint32 u16vector = 18 [packed = true]; repeated sint32 s16vector = 19 [packed = true]; repeated uint32 u32vector = 20 [packed = true]; repeated sint32 s32vector = 21 [packed = true]; - repeated uint64 u64vector = 22 [packed = true]; // for future extensions - repeated sint64 s64vector = 23 [packed = true]; // for future extensions + repeated uint64 u64vector = 22 [packed = true]; + repeated sint64 s64vector = 23 [packed = true]; repeated float f32vector = 24 [packed = true]; repeated double f64vector = 25 [packed = true]; optional bytes blob = 26; optional Custom custom = 13; optional Vector record = 14; optional uint64 shared = 15; } -// Arbitrary precision real numeric value. Either n or x should be set. +// Arbitrary precision real numeric value. Either numer or flonum should be set. message Real { optional sint64 numer = 1 [(extend.protobuf.max_size) = 0]; optional sint64 denom = 2 [default = 1, (extend.protobuf.max_size) = 0]; optional double flonum = 3; } Index: generator.scm ================================================================== --- generator.scm +++ generator.scm @@ -8,14 +8,14 @@ ;; 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 @@ -23,46 +23,46 @@ ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. (define make-identifier (let ([camel (sre->irregex '(: ($ lower) ($ upper)))] - [score (sre->irregex '("._"))]) + [score (sre->irregex '("._"))]) (lambda (str #!optional prefix) (string->symbol (conc - (or prefix "") - (if prefix ":" "") - (string-downcase - (irregex-replace/all - score (irregex-replace/all camel str 1 "-" 2) "-"))))))) + (or prefix "") + (if prefix ":" "") + (string-downcase + (irregex-replace/all + score (irregex-replace/all camel str 1 "-" 2) "-"))))))) (define (proto-file-register! types file) (define name (file-descriptor-proto-package file "main")) (define module (make-identifier name)) (define (register-identifier! path name prefix) (let ([path (string-append path "." name)] - [prefix (make-identifier name prefix)]) + [prefix (make-identifier name prefix)]) (hash-table-set! types path (cons module prefix)) (values path prefix))) (define (register-enum! path enum #!optional prefix) (register-identifier! path (enum-descriptor-proto-name enum) prefix)) - + (define (register-message! path msg #!optional prefix) (let-values ([(path prefix) - (register-identifier! - path (descriptor-proto-name msg) prefix)]) + (register-identifier! + path (descriptor-proto-name msg) prefix)]) (for-each (cut register-enum! path <> prefix) (descriptor-proto-enum-type msg '())) (for-each (cut register-message! path <> prefix) (descriptor-proto-nested-type msg '())))) - + (let ([path (string-append "." name)]) (for-each (cut register-enum! path <>) (file-descriptor-proto-enum-type file '())) (for-each @@ -76,107 +76,107 @@ (define imports (make-hash-table eq? symbol-hash)) (define (resolve-identifier! name prefix) (let-values ([(module symbol) - (car+cdr - (hash-table-ref - types name - (cut error prefix "unknown type" name)))]) + (car+cdr + (hash-table-ref + types name + (cut error prefix "unknown type" name)))]) (hash-table-set! imports module #t) symbol)) (define (translate-enum-definition enum #!optional prefix) (let ([name (make-identifier (enum-descriptor-proto-name enum) prefix)]) `((define-enum-type ,name - ,@(map - (lambda (item) - (list - (make-identifier (enum-value-descriptor-proto-name item)) - (enum-value-descriptor-proto-number item))) - (enum-descriptor-proto-value enum '())))))) - + ,@(map + (lambda (item) + (list + (make-identifier (enum-value-descriptor-proto-name item)) + (enum-value-descriptor-proto-number item))) + (enum-descriptor-proto-value enum '())))))) + (define (translate-field field prefix) (let ([name (make-identifier (field-descriptor-proto-name field))] - [options (field-descriptor-proto-options field make-field-options)]) + [options (field-descriptor-proto-options field make-field-options)]) (cons* (case (field-descriptor-proto-label field) - [(label-required) 'required] - [(label-optional) 'optional] - [(label-repeated) - (if (field-options-packed options #f) 'packed 'repeated)]) + [(label-required) 'required] + [(label-optional) 'optional] + [(label-repeated) + (if (field-options-packed options #f) 'packed 'repeated)]) (case (field-descriptor-proto-type field) - [(type-int32) 'int32] - [(type-int64) 'int64] - [(type-uint32) 'uint32] - [(type-uint64) - (let ([max-size (field-options-max-size options)]) - (if (= max-size 10) - 'uint64 - `(uint* ,(and (positive? max-size) max-size))))] - [(type-sint32) 'sint32] - [(type-sint64) - (let ([max-size (field-options-max-size options)]) - (if (= max-size 10) - 'sint64 - `(sint* ,(and (positive? max-size) max-size))))] - [(type-fixed32) 'fixed32] - [(type-fixed64) 'fixed64] - [(type-sfixed32) 'sfixed32] - [(type-sfixed64) 'sfixed64] - [(type-bool) 'bool] - [(type-float) 'float] - [(type-double) 'double] - [(type-bytes) 'bytes] - [(type-string) 'string] - [else (resolve-identifier! (field-descriptor-proto-type-name field) name)]) + [(type-int32) 'int32] + [(type-int64) 'int64] + [(type-uint32) 'uint32] + [(type-uint64) + (let ([max-size (field-options-max-size options)]) + (if (= max-size 10) + 'uint64 + `(uint* ,(and (positive? max-size) max-size))))] + [(type-sint32) 'sint32] + [(type-sint64) + (let ([max-size (field-options-max-size options)]) + (if (= max-size 10) + 'sint64 + `(sint* ,(and (positive? max-size) max-size))))] + [(type-fixed32) 'fixed32] + [(type-fixed64) 'fixed64] + [(type-sfixed32) 'sfixed32] + [(type-sfixed64) 'sfixed64] + [(type-bool) 'bool] + [(type-float) 'float] + [(type-double) 'double] + [(type-bytes) 'bytes] + [(type-string) 'string] + [else (resolve-identifier! (field-descriptor-proto-type-name field) name)]) name (field-descriptor-proto-number field) (let ([default (field-descriptor-proto-default-value field void)]) - (if (eq? default (void)) - '() - (list - (case (field-descriptor-proto-type field) - [(type-int32 type-int64 - type-uint32 type-uint64 - type-sint32 type-sint64 - type-fixed32 type-fixed64 - type-sfixed32 type-sfixed64 - type-float type-double - type-bytes) - (call-with-input-string default read)] - [(type-bool) - (not (equal? default "false"))] - [(type-enum) - `(quote ,(make-identifier default))] - [(type-string) - default] - [else - (error prefix "unsupported default value" name default)]))))))) - + (if (eq? default (void)) + '() + (list + (case (field-descriptor-proto-type field) + [(type-int32 type-int64 + type-uint32 type-uint64 + type-sint32 type-sint64 + type-fixed32 type-fixed64 + type-sfixed32 type-sfixed64 + type-float type-double + type-bytes) + (call-with-input-string default read)] + [(type-bool) + (not (equal? default "false"))] + [(type-enum) + `(quote ,(make-identifier default))] + [(type-string) + default] + [else + (error prefix "unsupported default value" name default)]))))))) + (define (translate-message-definition msg #!optional prefix) (let ([name (make-identifier (descriptor-proto-name msg) prefix)]) (append (append-map - (cut translate-enum-definition <> name) - (descriptor-proto-enum-type msg '())) - (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 '()))))))) - + (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) ')]) `((define-message-extension ,name - ,(translate-field ext name))))) - + ,(translate-field ext name))))) + (define body (append (append-map translate-enum-definition (file-descriptor-proto-enum-type file '())) @@ -194,20 +194,20 @@ (pathname-replace-extension (file-descriptor-proto-name file) "scm") #:content (call-with-output-string (lambda (port) - (display ";; Generated by protoc-gen-chicken v1.0.0" port) + (display ";; Generated by protoc-gen-chicken v1.2.3" port) (newline port) (pretty-print - `(module ,module - * - (import - (except scheme string) chicken protobuf-syntax - ,@(hash-table-keys imports)) - ,@body) - port))))) + `(module ,module + * + (import + (except scheme string) (chicken base) protobuf-syntax + ,@(hash-table-keys imports)) + ,@body) + port))))) (define (generate-chicken request) (define files (make-hash-table string=? string-hash)) (define types @@ -216,11 +216,11 @@ (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) @@ -229,5 +229,7 @@ [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: ;; Index: generic.scm ================================================================== --- generic.scm +++ generic.scm @@ -8,14 +8,14 @@ ;; 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 @@ -22,12 +22,12 @@ ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. (define-record-type (serialization-context - #:uid 'protobuf:serialization-context - #:opaque #t #:sealed #t) + #:uid 'protobuf:serialization-context + #:opaque #t #:sealed #t) #f #t obj->ref ref->obj) (define current-serialization-context @@ -35,36 +35,33 @@ (define make-serialization-context (let ([make-serialization-context* (rtd-constructor serialization-context)]) (lambda vs (let* ([obj->ref (make-hash-table eq? eq?-hash)] - [ref->obj (make-hash-table eqv? eqv?-hash)] - [context (make-serialization-context* obj->ref ref->obj)]) - (do-ec (:list v (index ref) (cons context vs)) - (begin - (hash-table-set! obj->ref v ref) - (hash-table-set! ref->obj ref v))) - context)))) + [ref->obj (make-hash-table eqv? eqv?-hash)] + [context (make-serialization-context* obj->ref ref->obj)]) + (do-ec (:list v (index ref) (cons context vs)) + (begin + (hash-table-set! obj->ref v ref) + (hash-table-set! ref->obj ref v))) + context)))) (define (serialization-context-rememberer context) (let ([obj->ref (serialization-context-obj->ref context)] - [ref->obj (serialization-context-ref->obj context)]) + [ref->obj (serialization-context-ref->obj context)]) (lambda (v) - (cond - [(hash-table-ref/default obj->ref v #f) - => values] - [else - (let ([ref (hash-table-size ref->obj)]) - (hash-table-set! obj->ref v ref) - (hash-table-set! ref->obj ref v)) - #f])))) + (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) + #:uid 'protobuf:serialization-info) #t #t reader writer) (define %procedure-id (foreign-lambda* c-string ([scheme-object proc]) @@ -85,42 +82,43 @@ (define remember! void) (define (write-real v port) (if (exact? v) - (let ([numer (numerator v)] - [denom (denominator v)]) - (unless (zero? numer) - (write-tag/type 1 'int* port) - (write-sint* numer port #f)) - (unless (= 1 denom) - (write-tag/type 2 'int* port) - (write-sint* denom port #f))) - (begin - (write-tag/type 3 '64bit port) - (write-double v port)))) + (let ([numer (numerator v)] + [denom (denominator v)]) + (unless (zero? numer) + (write-tag/type 1 'int* port) + (write-sint* numer port #f)) + (unless (= 1 denom) + (write-tag/type 2 'int* port) + (write-sint* denom port #f))) + (begin + (write-tag/type 3 '64bit port) + (write-double v port)))) (define (write-complex v port) (let ([real (real-part v)] - [imag (imag-part v)]) + [imag (imag-part v)]) (unless (zero? real) - (write-tag/type 1 'sized port) - (write-sized write-real real port)) + (write-tag/type 1 'sized port) + (write-sized write-real real port)) (unless (zero? imag) - (write-tag/type 2 'sized port) - (write-sized write-real imag port)))) + (write-tag/type 2 'sized port) + (write-sized write-real imag port)))) + + (define (write-keyword v port) + (write-tag/type 1 'sized port) + (write-sized-string (keyword->string v) port) + (write-tag/type 2 'int* port) + (write-int* 3 port)) (define (write-symbol v port) (write-tag/type 1 'sized port) (write-sized-string (symbol->string v) port) - (cond - [(not (##sys#interned-symbol? v)) - (write-tag/type 2 'int* port) - (write-int* 2 port)] - [(keyword? v) - (write-tag/type 2 'int* port) - (write-int* 3 port)])) + (write-tag/type 2 'int* port) + (write-int* (if (##sys#interned-symbol? v) 1 2) 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) @@ -127,63 +125,63 @@ (write-sized write-value (cdr v) port)) (define ((write-block i0) block port) (do-ec (:range i i0 (##sys#size block)) (begin - (write-tag/type 1 'sized port) - (write-sized write-value (##sys#slot block i) port)))) + (write-tag/type 1 'sized port) + (write-sized write-value (##sys#slot block i) port)))) (define write-vector (write-block 0)) (define (write-hash-table v port) (let ([v (hash-table-equivalence-function v)]) (unless (eq? v equal?) (write-tag/type 2 'sized port) - (write-sized write-value v port))) + (write-sized write-value v port))) (let ([v (hash-table-hash-function v)]) (unless (eq? v equal?-hash) (write-tag/type 3 'sized port) - (write-sized write-value v port))) + (write-sized write-value v port))) (let ([v (hash-table-min-load v)]) (unless (= v 0.5) - (write-tag/type 4 '64bit port) - (write-double v port))) + (write-tag/type 4 '64bit port) + (write-double v port))) (let ([v (hash-table-max-load v)]) (unless (= v 0.8) - (write-tag/type 5 '64bit port) - (write-double v port))) + (write-tag/type 5 '64bit port) + (write-double v port))) (let ([v (hash-table-weak-keys v)]) (when v - (write-tag/type 6 'int* port) - (write-bool v port))) + (write-tag/type 6 'int* port) + (write-bool v port))) (let ([v (hash-table-weak-values v)]) (when v - (write-tag/type 7 'int* port) - (write-bool v port))) + (write-tag/type 7 'int* port) + (write-bool v port))) (let ([v (hash-table-initial v)]) (when v - (write-tag/type 8 'sized port) - (write-sized write-value v port))) + (write-tag/type 8 'sized port) + (write-sized write-value v port))) (hash-table-walk v (lambda (k v) (write-tag/type 1 'sized port) (write-sized write-pair (cons k v) port)))) (define write-procedure (let ([write-upvalues (write-block 1)]) (lambda (v port) - (write-tag/type 2 'sized port) - (write-sized-string (%procedure-id v) port) - (write-upvalues v port)))) + (write-tag/type 2 'sized port) + (write-sized-string (%procedure-id v) port) + (write-upvalues v port)))) (define ((write-custom info) v port) (let ([reader (serialization-info-reader info)]) (unless (eq? reader read) - (write-tag/type 2 'sized port) - (write-sized write-value reader port))) + (write-tag/type 2 'sized port) + (write-sized write-value reader port))) (write-tag/type 1 'sized port) (write-sized (serialization-info-writer info) v port)) (define (write-value v port) (cond @@ -209,19 +207,22 @@ (write-tag/type 3 'int* port) (write-sint* v port)] [(remember! v) => (lambda (ref) - (write-tag/type 15 'int* port) - (write-uint* ref port))] + (write-tag/type 15 'int* port) + (write-uint* ref port))] [(number? v) (write-tag/type 5 'sized port) (write-sized write-complex v port)] [(string? v) (write-tag/type 6 'sized port) (write-sized-string v port)] + [(keyword? v) + (write-tag/type 7 'sized port) + (write-sized write-keyword v port)] [(symbol? v) (write-tag/type 7 'sized port) (write-sized write-symbol v port)] [(pair? v) (write-tag/type 8 'sized port) @@ -248,41 +249,41 @@ (write-sized-bytes (blob->u8vector/shared (s8vector->blob/shared v)) port)] [(u16vector? v) (write-tag/type 18 'sized port) (write-sized (lambda (block port) - (do-ec (:u16vector v block) (write-uint* v port))) + (do-ec (:u16vector v block) (write-uint* v port))) v port)] [(s16vector? v) (write-tag/type 19 'sized port) (write-sized (lambda (block port) - (do-ec (:s16vector v block) (write-sint* v port))) + (do-ec (:s16vector v block) (write-sint* v port))) v port)] [(u32vector? v) (write-tag/type 20 'sized port) (write-sized (lambda (block port) - (do-ec (:u32vector v block) (write-uint* v port))) + (do-ec (:u32vector v block) (write-uint* v port))) v port)] [(s32vector? v) (write-tag/type 21 'sized port) (write-sized (lambda (block port) - (do-ec (:s32vector v block) (write-sint* v port))) + (do-ec (:s32vector v block) (write-sint* v port))) v port)] - #;[(u64vector? v) + [(u64vector? v) (write-tag/type 22 'sized port) (write-sized (lambda (block port) - (do-ec (:u64vector v block) (write-uint* v port))) + (do-ec (:u64vector v block) (write-uint* v port))) v port)] - #;[(s64vector? v) + [(s64vector? v) (write-tag/type 23 'sized port) (write-sized (lambda (block port) - (do-ec (:s64vector v block) (write-sint* v port))) + (do-ec (:s64vector v block) (write-sint* v port))) v port)] [(f32vector? v) (write-tag/type 24 'sized port) (write-sized-bytes (blob->u8vector/shared (f32vector->blob/shared v)) port)] [(f64vector? v) @@ -293,16 +294,16 @@ (write-sized-bytes (blob->u8vector/shared v) port)] [(record? v) (cond [(prop:serialization-info v) - => (lambda (info) - (write-tag/type 13 'sized port) - (write-sized (write-custom info) v port))] + => (lambda (info) + (write-tag/type 13 'sized port) + (write-sized (write-custom info) v port))] [else - (write-tag/type 14 'sized port) - (write-sized write-vector v port)])] + (write-tag/type 14 'sized port) + (write-sized write-vector v port)])] [else (error 'serialize "cannot serialize value" v)])) (unless context @@ -321,25 +322,25 @@ actual))) (define (reverse!/length tail) (let next ([head '()] [tail tail] [length 0]) (if (pair? tail) - (let ([rest (cdr tail)]) - (set-cdr! tail head) - (next tail rest (fx+ length 1))) - (values head length)))) + (let ([rest (cdr tail)]) + (set-cdr! tail head) + (next tail rest (fx+ length 1))) + (values head length)))) (define-record-type (hash-table-dummy - #:opaque #t #:sealed #t) + #:opaque #t #:sealed #t) #t #t test hash min-load max-load weak-keys weak-values initial size slots) (define-record-type (custom-dummy - #:opaque #t #:sealed #t) + #:opaque #t #:sealed #t) #t #f data reader) (define (deserialize #!optional [port (current-input-port)] [context (current-serialization-context)]) (define remember! @@ -346,92 +347,92 @@ void) (define (read-real port) (let more ([v 1]) (let-values ([(tag type) (read-tag/type port)]) - (case tag - [(1) - (ensure-type 'int* type "numerator") - (more (* v (read-sint* port #f)))] - [(2) - (ensure-type 'int* type "denominator") - (more (/ v (read-sint* port #f)))] - [(3) - (ensure-type '64bit type "flonum") - (more (read-double port))] - [(#!eof) - v] - [else - (syntax-error 'deserialize "unknown real part" tag)])))) + (case tag + [(1) + (ensure-type 'int* type "numerator") + (more (* v (read-sint* port #f)))] + [(2) + (ensure-type 'int* type "denominator") + (more (/ v (read-sint* port #f)))] + [(3) + (ensure-type '64bit type "flonum") + (more (read-double port))] + [(#!eof) + v] + [else + (syntax-error 'deserialize "unknown real part" tag)])))) (define (read-complex port) (let more ([real 0] [imag 0]) (let-values ([(tag type) (read-tag/type port)]) - (case tag - [(1) - (ensure-type 'sized type "real part") - (more (read-sized read-real port) imag)] - [(2) - (ensure-type 'sized type "imaginary part") - (more real (read-sized read-real port))] - [(#!eof) - (make-rectangular real imag)] - [else - (syntax-error 'deserialize "unknown complex part" tag)])))) + (case tag + [(1) + (ensure-type 'sized type "real part") + (more (read-sized read-real port) imag)] + [(2) + (ensure-type 'sized type "imaginary part") + (more real (read-sized read-real port))] + [(#!eof) + (make-rectangular real imag)] + [else + (syntax-error 'deserialize "unknown complex part" tag)])))) (define (read-symbol port) (let more ([id #f] [import-symbol string->symbol]) (let-values ([(tag type) (read-tag/type port)]) - (case tag - [(1) - (ensure-type 'sized type "symbol id") - (more (read-sized-string port) import-symbol)] - [(2) - (ensure-type 'int* type "symbol type") - (let ([tag (read-int* port)]) - (case tag - [(1) (more id string->symbol)] - [(2) (more id string->uninterned-symbol)] - [(3) (more id string->keyword)] - [else (syntax-error 'deserialize "unknown symbol type" tag)]))] - [(#!eof) - (if id - (import-symbol id) - (syntax-error 'deserialize "missing symbol id"))] - [else - (syntax-error 'deserialize "unknown symbol part" tag)])))) + (case tag + [(1) + (ensure-type 'sized type "symbol id") + (more (read-sized-string port) import-symbol)] + [(2) + (ensure-type 'int* type "symbol type") + (let ([tag (read-int* port)]) + (case tag + [(1) (more id string->symbol)] + [(2) (more id string->uninterned-symbol)] + [(3) (more id string->keyword)] + [else (syntax-error 'deserialize "unknown symbol type" tag)]))] + [(#!eof) + (if id + (import-symbol id) + (syntax-error 'deserialize "missing symbol id"))] + [else + (syntax-error 'deserialize "unknown symbol part" tag)])))) (define ((read-pair! v) port) (let more () (let-values ([(tag type) (read-tag/type port)]) - (case tag - [(1) - (ensure-type 'sized type "car") - (set-car! v (read-sized read-value port)) - (more)] - [(2) - (ensure-type 'sized type "cdr") - (set-cdr! v (read-sized read-value port)) - (more)] - [(#!eof) - v] - [else - (syntax-error 'deserialize "unknown pair part" tag)])))) + (case tag + [(1) + (ensure-type 'sized type "car") + (set-car! v (read-sized read-value port)) + (more)] + [(2) + (ensure-type 'sized type "cdr") + (set-cdr! v (read-sized read-value port)) + (more)] + [(#!eof) + v] + [else + (syntax-error 'deserialize "unknown pair part" tag)])))) (define ((read-block read-special make-block) port) (let more ([slots '()] [specials '()]) (let-values ([(tag type) (read-tag/type port)]) - (case tag - [(1) - (ensure-type 'sized type "slot") - (more (cons (read-sized-string port) slots) specials)] - [(#!eof) - (let-values ([(slots length) (reverse!/length slots)]) - (apply make-block length slots specials))] - [else - (let-values ([special (read-special tag type port)]) - (more slots (append special specials)))])))) + (case tag + [(1) + (ensure-type 'sized type "slot") + (more (cons (read-sized-string port) slots) specials)] + [(#!eof) + (let-values ([(slots length) (reverse!/length slots)]) + (apply make-block length slots specials))] + [else + (let-values ([special (read-special tag type port)]) + (more slots (append special specials)))])))) (define ((decode-block! i0) v) (do-ec (:range i i0 (##sys#size v)) (##sys#setslot v i (call-with-input-string (##sys#slot v i) read-value))) v) @@ -448,270 +449,270 @@ (define read-hash-table* (read-block (lambda (tag type port) (case tag - [(2) - (ensure-type 'sized type "equality function") - (values #:test (read-sized-string port))] - [(3) - (ensure-type 'sized type "hash function") - (values #:hash (read-sized-string port))] - [(4) - (ensure-type '64bit type "minimum load factor") - (values #:min-load (read-double port))] - [(5) - (ensure-type '64bit type "maximum load factor") - (values #:max-load (read-double port))] - [(6) - (ensure-type 'int* type "weak keys flag") - (values #:weak-keys (read-bool port))] - [(7) - (ensure-type 'int* type "weak values flag") - (values #:weak-values (read-bool port))] - [(8) - (ensure-type 'sized type "initial value") - (values #:initial (read-sized-string port))] - [else - (syntax-error 'deserialize "unknown hash table part" tag)])) + [(2) + (ensure-type 'sized type "equality function") + (values #:test (read-sized-string port))] + [(3) + (ensure-type 'sized type "hash function") + (values #:hash (read-sized-string port))] + [(4) + (ensure-type '64bit type "minimum load factor") + (values #:min-load (read-double port))] + [(5) + (ensure-type '64bit type "maximum load factor") + (values #:max-load (read-double port))] + [(6) + (ensure-type 'int* type "weak keys flag") + (values #:weak-keys (read-bool port))] + [(7) + (ensure-type 'int* type "weak values flag") + (values #:weak-values (read-bool port))] + [(8) + (ensure-type 'sized type "initial value") + (values #:initial (read-sized-string port))] + [else + (syntax-error 'deserialize "unknown hash table part" tag)])) (lambda (n slots #!key test hash [min-load 0.5] [max-load 0.8] weak-keys weak-values initial) (if (or test hash initial) - (make-hash-table-dummy - test hash min-load max-load weak-keys weak-values initial - n slots) - (alist->hash-table - (list (cons 'slots slots)) - #:min-load min-load #:max-load max-load - #:weak-keys weak-keys #:weak-values weak-values - #:size n))))) + (make-hash-table-dummy + test hash min-load max-load weak-keys weak-values initial + n slots) + (alist->hash-table + (list (cons 'slots slots)) + #:min-load min-load #:max-load max-load + #:weak-keys weak-keys #:weak-values weak-values + #:size n))))) (define (decode-hash-table! v) (let ([slots - (if (hash-table-dummy? v) - (let* ([test - (cond - [(hash-table-dummy-test v) => decode-value] - [else equal?])] - [hash - (cond - [(hash-table-dummy-hash v) => decode-value] - [else equal?-hash])] - [min-load - (hash-table-dummy-min-load v)] - [max-load - (hash-table-dummy-max-load v)] - [weak-keys - (hash-table-dummy-weak-keys v)] - [weak-values - (hash-table-dummy-weak-values v)] - [initial - (cond - [(hash-table-dummy-initial v) => decode-value] - [else #f])] - [size - (hash-table-dummy-size v)] - [slots - (hash-table-dummy-slots v)]) - (object-become! - (list - (cons - v - (make-hash-table - #:test test #:hash hash - #:min-load min-load #:max-load max-load - #:weak-keys weak-keys #:weak-values weak-values - #:initial initial #:size size)))) - slots) - (let ([slots (hash-table-ref v 'slots)]) - (hash-table-delete! v 'slots) - slots))]) + (if (hash-table-dummy? v) + (let* ([test + (cond + [(hash-table-dummy-test v) => decode-value] + [else equal?])] + [hash + (cond + [(hash-table-dummy-hash v) => decode-value] + [else equal?-hash])] + [min-load + (hash-table-dummy-min-load v)] + [max-load + (hash-table-dummy-max-load v)] + [weak-keys + (hash-table-dummy-weak-keys v)] + [weak-values + (hash-table-dummy-weak-values v)] + [initial + (cond + [(hash-table-dummy-initial v) => decode-value] + [else #f])] + [size + (hash-table-dummy-size v)] + [slots + (hash-table-dummy-slots v)]) + (object-become! + (list + (cons + v + (make-hash-table + #:test test #:hash hash + #:min-load min-load #:max-load max-load + #:weak-keys weak-keys #:weak-values weak-values + #:initial initial #:size size)))) + slots) + (let ([slots (hash-table-ref v 'slots)]) + (hash-table-delete! v 'slots) + slots))]) (do-ec (:list s slots) - (let ([k+v (call-with-input-string s (read-pair! (cons #f #f)))]) - (hash-table-set! v (car k+v) (cdr k+v))))) + (let ([k+v (call-with-input-string s (read-pair! (cons #f #f)))]) + (hash-table-set! v (car k+v) (cdr k+v))))) v) (define read-procedure* (read-block (lambda (tag type port) (case tag - [(2) - (ensure-type 'sized type "procedure id") - (read-sized-string port)] - [else - (syntax-error 'deserialize "unknown procedure part" tag)])) + [(2) + (ensure-type 'sized type "procedure id") + (read-sized-string port)] + [else + (syntax-error 'deserialize "unknown procedure part" tag)])) (lambda (n slots #!optional id) (let ([v (##sys#allocate-vector (fx+ n 1) #f (void) #f)]) - (unless (%procedure-id-set! v id) - (syntax-error 'deserialize "invalid procedure id" id)) - (do-ec (:list s (index i) slots) (##sys#setslot v (fx+ i 1) s)) - v)))) + (unless (%procedure-id-set! v id) + (syntax-error 'deserialize "invalid procedure id" id)) + (do-ec (:list s (index i) slots) (##sys#setslot v (fx+ i 1) s)) + v)))) (define decode-procedure! (decode-block! 1)) (define read-custom* (read-block (lambda (tag type port) (case tag - [(2) - (ensure-type 'sized type "custom reader") - (read-sized-string port)] - [else - (syntax-error 'deserialize "unknown custom value part" tag)])) + [(2) + (ensure-type 'sized type "custom reader") + (read-sized-string port)] + [else + (syntax-error 'deserialize "unknown custom value part" tag)])) (lambda (n data #!optional reader) (make-custom-dummy (string-concatenate data) reader)))) (define (decode-custom! v) (object-become! (list (cons v (call-with-input-string - (custom-dummy-data v) - (cond - [(custom-dummy-reader v) => decode-value] - [else read]))))) + (custom-dummy-data v) + (cond + [(custom-dummy-reader v) => decode-value] + [else read]))))) v) (define read-record* (read-block (lambda (tag type port) (syntax-error 'deserialize "unknown record part" tag)) (lambda (n slots #!optional id) (let ([v (##sys#allocate-vector n #f (void) #f)]) - (##core#inline "C_vector_to_structure" v) - (do-ec (:list s (index i) slots) (##sys#setslot v i s)) - v)))) + (##core#inline "C_vector_to_structure" v) + (do-ec (:list s (index i) slots) (##sys#setslot v i s)) + v)))) (define (read-value port) (let-values ([(tag type) (read-tag/type port)]) (case tag - [(1) - (ensure-type 'int* type "special value") - (let ([tag (read-int* port)]) - (case tag - [(1) (void)] - [(2) '()] - [(3) #!eof] - [(4) #f] - [(5) #t] - [else (syntax-error 'deserialize "unknown special value" tag)]))] - [(2) - (ensure-type 'int* type "char") - (integer->char (read-int* port))] - [(3) - (ensure-type 'int* type "fixnum") - (read-sint* port)] - - [(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)]))) + [(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 @@ -719,9 +720,11 @@ (make-serialization-context (current-input-port) (current-output-port) (current-error-port)))) (set! remember! (let ([rememberer (serialization-context-rememberer context)]) (lambda (v) - (rememberer v) - v))) + (rememberer v) + v))) (parameterize ([current-serialization-context context]) (read-value port))) + +;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;; Index: google/protobuf/compiler/plugin.scm ================================================================== --- google/protobuf/compiler/plugin.scm +++ google/protobuf/compiler/plugin.scm @@ -1,10 +1,14 @@ -;; Generated by protoc-gen-chicken v1.0.0 +;; Generated by protoc-gen-chicken v1.1.3 (module google-protobuf-compiler * - (import (except scheme string) chicken protobuf-syntax google-protobuf) + (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)) Index: google/protobuf/descriptor.scm ================================================================== --- google/protobuf/descriptor.scm +++ google/protobuf/descriptor.scm @@ -1,18 +1,20 @@ -;; Generated by protoc-gen-chicken v1.0.0 +;; Generated by protoc-gen-chicken v1.1.3 (module google-protobuf * - (import (except scheme string) chicken protobuf-syntax) + (import (except scheme string) (chicken base) protobuf-syntax) (define-message-type file-descriptor-set (repeated file-descriptor-proto file 1)) (define-message-type file-descriptor-proto (optional string name 1) (optional string package 2) (repeated string dependency 3) + (repeated int32 public-dependency 10) + (repeated int32 weak-dependency 11) (repeated descriptor-proto message-type 4) (repeated enum-descriptor-proto enum-type 5) (repeated service-descriptor-proto service 6) (repeated field-descriptor-proto extension 7) (optional file-options options 8) @@ -27,10 +29,11 @@ (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) @@ -62,11 +65,13 @@ (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)) @@ -95,39 +100,50 @@ 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)) @@ -141,9 +157,11 @@ (optional bytes string-value 7) (optional string aggregate-value 8)) (define-message-type source-code-info:location (packed int32 path 1) - (packed int32 span 2)) + (packed int32 span 2) + (optional string leading-comments 3) + (optional string trailing-comments 4)) (define-message-type source-code-info (repeated source-code-info:location location 1))) Index: main.scm ================================================================== --- main.scm +++ main.scm @@ -8,14 +8,14 @@ ;; 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 @@ -22,11 +22,15 @@ ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. (define ((appender accessor mutator) msg v) - (mutator msg (append (accessor msg '()) (if (list? v) v (list v))))) + (mutator + msg + (if (list? v) + (foldl (flip cons) (accessor msg '()) v) + (cons v (accessor msg '()) )))) (define (deserialize type #!optional [port (current-input-port)]) (let ([info (prop:protobuf #f type)]) (letrec ([msg ((message-info-constructor info))] [fields (message-info-fields info)] @@ -37,51 +41,51 @@ (unless (or (eof-object? tag) (eof-object? type)) (hash-table-delete! required tag) (cond [(hash-table-ref/default fields tag #f) => (lambda (field) - (let* ([ftype (field-info-type field)] - [repeated? (field-info-repeated? field)] - [accessor (field-info-accessor field)] - [mutator (field-info-mutator field)] - [updator - (if repeated? - (appender accessor mutator) - mutator)]) - (cond - [(primitive-info? ftype) - (let ([ptype (primitive-info-type ftype)] - [read (primitive-info-reader ftype)]) - (updator - msg - (cond - [(eq? type ptype) - (read port)] - [(and repeated? (eq? type 'sized) (not (eq? ptype 'sized))) - (read-sized (cut read-file <> read) port)] - [else - (syntax-error 'deserialize "wire type does not match declared type" type)])))] - [(enum-info? ftype) - (let ([integer->enum (enum-info-integer->enum ftype)]) - (updator - msg - (cond - [(eq? type 'int*) - (integer->enum (read-int* port))] - [(and repeated? (eq? type 'sized)) - (map integer->enum - (read-sized (cut read-file <> read-int*) port))] - [else - (syntax-error 'deserialize "wire type does not match declared type" type)])))] - [(rtd? ftype) - (updator - msg - (cond - [(eq? type 'sized) - (read-sized (cut deserialize ftype <>) port)] - [else - (syntax-error 'deserialize "wire type does not match declared type" type)]))])))] + (let* ([ftype (field-info-type field)] + [repeated? (field-info-repeated? field)] + [accessor (field-info-accessor field)] + [mutator (field-info-mutator field)] + [updator + (if repeated? + (appender accessor mutator) + mutator)]) + (cond + [(primitive-info? ftype) + (let ([ptype (primitive-info-type ftype)] + [read (primitive-info-reader ftype)]) + (updator + msg + (cond + [(eq? type ptype) + (read port)] + [(and repeated? (eq? type 'sized) (not (eq? ptype 'sized))) + (read-sized (cut read-list <> read) port)] + [else + (syntax-error 'deserialize "wire type does not match declared type" type)])))] + [(enum-info? ftype) + (let ([integer->enum (enum-info-integer->enum ftype)]) + (updator + msg + (cond + [(eq? type 'int*) + (integer->enum (read-int* port))] + [(and repeated? (eq? type 'sized)) + (map integer->enum + (read-sized (cut read-list <> read-int*) port))] + [else + (syntax-error 'deserialize "wire type does not match declared type" type)])))] + [(rtd? ftype) + (updator + msg + (cond + [(eq? type 'sized) + (read-sized (cut deserialize ftype <>) port)] + [else + (syntax-error 'deserialize "wire type does not match declared type" type)]))])))] [else (write-tag/type tag type unknown) (case type [(int*) (write-uint* (read-uint* port) unknown)] @@ -95,53 +99,62 @@ (copy-port (make-limited-input-port port size #f) unknown))])]) (loop)))) (message-unknown-set! msg (get-output-string unknown)) (unless (zero? (hash-table-size required)) (syntax-error 'deserialize "missing required fields" (hash-table-keys required))) + (for-each (lambda (field) + (let [(content ((field-info-accessor field) msg))] + (when (and (field-info-repeated? field) (list? content)) + ((field-info-mutator field) msg (reverse content))))) (hash-table-values fields)) msg))) (define (serialize msg #!optional [port (current-output-port)]) (let ([info (prop:protobuf msg)]) (let ([fields (message-info-fields info)] [required (hash-table-copy (message-info-required info))]) (hash-table-walk fields (lambda (tag field) - (let ([vs ((field-info-accessor field) msg void)]) - (unless (eq? vs (void)) - (let ([repeated? (field-info-repeated? field)] - [packed? (field-info-packed? field)]) - (for-each - (lambda (v) - (hash-table-delete! required tag) - (let ([ftype (field-info-type field)]) - (cond - [(primitive-info? ftype) - (let ([ptype (primitive-info-type ftype)] - [write (primitive-info-writer ftype)]) - (cond - [(and repeated? packed?) - (when (eq? ptype 'sized) - (error 'serialize "cannot apply packed encoding to sized type")) - (write-tag/type tag 'sized port) - (write-sized - (cut for-each write <> <>) vs port)] - [else - (write-tag/type tag ptype port) - (write v port)]))] - [(enum-info? ftype) - (let ([enum->integer (enum-info-enum->integer ftype)]) - (cond - [(and repeated? packed?) - (write-tag/type tag 'sized port) - (write-sized - (cut for-each write-int* <> <>) (map enum->integer vs) port)] - [else - (write-tag/type tag 'int* port) - (write-int* (enum->integer v) port)]))] - [else - (write-tag/type tag 'sized port) - (write-sized serialize v port)]))) - (if (and repeated? (not packed?)) vs (list vs)))))))) + (let ([vs ((field-info-accessor field) msg void)]) + (unless (eq? vs (void)) + (let ([repeated? (field-info-repeated? field)] + [packed? (field-info-packed? field)]) + (for-each + (lambda (v) + (hash-table-delete! required tag) + (let ([ftype (field-info-type field)]) + (cond + [(primitive-info? ftype) + (let ([ptype (primitive-info-type ftype)] + [write (primitive-info-writer ftype)]) + (cond + [(and repeated? packed?) + (when (eq? ptype 'sized) + (error 'serialize "cannot apply packed encoding to sized type")) + (write-tag/type tag 'sized port) + (write-sized + (lambda (v p) + (for-each (cut write <> p) v)) vs port)] + [else + (write-tag/type tag ptype port) + (write v port)]))] + [(enum-info? ftype) + (let ([enum->integer (enum-info-enum->integer ftype)]) + (cond + [(and repeated? packed?) + (write-tag/type tag 'sized port) + (write-sized + (lambda (v p) + (for-each (cut write-int* <> p) v)) + (map enum->integer vs) port)] + [else + (write-tag/type tag 'int* port) + (write-int* (enum->integer v) port)]))] + [else + (write-tag/type tag 'sized port) + (write-sized serialize v port)]))) + (if (and repeated? (not packed?)) vs (list vs)))))))) (write-string (message-unknown msg) #f port) (unless (zero? (hash-table-size required)) (syntax-error 'serialize "missing required fields" (hash-table-keys required)))))) + +;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;; ADDED protobuf.egg Index: protobuf.egg ================================================================== --- /dev/null +++ protobuf.egg @@ -0,0 +1,41 @@ +((category data io) + (synopsis "Protocol buffer serialization") + (author "Thomas Chust") + (license "BSD") + (version "1.2.3") + (dependencies + srfi-13 + srfi-18 + srfi-42 + srfi-69 + srfi-99) + (test-dependencies + test) + (components + (extension protobuf + (modules + protobuf + protobuf-encoding + protobuf-reflection + protobuf-syntax + protobuf-generic) + (source-dependencies + "srfi-4-comprehensions.scm" + "encoding.scm" + "reflection.scm" + "syntax.scm" + "generic.scm")) + (program protoc-gen-chicken + (component-dependencies + protobuf) + (source-dependencies + "google/protobuf/descriptor.scm" + "extend/protobuf/bigint.scm" + "google/protobuf/compiler/plugin.scm" + "generator.scm")) + (c-include extend/protobuf + (files + "extend/protobuf/bigint.proto" + "extend/protobuf/chicken.proto")))) + +;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;; DELETED protobuf.meta Index: protobuf.meta ================================================================== --- protobuf.meta +++ /dev/null @@ -1,19 +0,0 @@ -;; -*- 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")) ADDED protobuf.release-info Index: protobuf.release-info ================================================================== --- /dev/null +++ protobuf.release-info @@ -0,0 +1,9 @@ +(repo fossil "https://chust.org/repos/chicken-{egg-name}") + +(uri targz "https://chust.org/repos/chicken-{egg-name}/tarball/{egg-name}.tar.gz?uuid=v{egg-release}") +(release "1.2.3") +(release "1.2.2") +(release "1.2.1") +(release "1.2.0") + +;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;; Index: protobuf.scm ================================================================== --- protobuf.scm +++ protobuf.scm @@ -8,27 +8,31 @@ ;; files (the Software), to deal in the Software without restriction, ;; including without limitation the rights to use, copy, modify, ;; merge, publish, distribute, sublicense, and/or sell copies of the ;; Software, and to permit persons to whom the Software is furnished ;; to do so, subject to the following conditions: -;; +;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. -;; +;; ;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. -(require-library - srfi-4 srfi-13 srfi-18 srfi-42 srfi-4-comprehensions srfi-69 srfi-99 - ports extras - numbers) +(module srfi-4-comprehensions + * + (import + scheme + (chicken base) + (chicken fixnum) + srfi-4 srfi-42) + (include "srfi-4-comprehensions.scm")) (module protobuf-encoding (make-limited-input-port read-uint* write-uint* read-sint* write-sint* @@ -41,13 +45,19 @@ read-sized-bytes write-sized-bytes read-sized-string write-sized-string read-sized write-sized read-tag/type write-tag/type) (import - scheme chicken - srfi-4 (only srfi-18 raise) srfi-42 srfi-4-comprehensions - ports extras numbers) + scheme + (chicken base) + (chicken fixnum) + (chicken bitwise) + (chicken io) + (chicken port) + (chicken syntax) + srfi-4 srfi-4-comprehensions srfi-42 + (only srfi-18 raise)) (include "encoding.scm")) (module protobuf-reflection (type-info type-info? @@ -72,12 +82,14 @@ message? message-extensions message-unknown message-unknown-set! prop:protobuf) (import - scheme (except chicken define-record-type) - srfi-69 srfi-99) + scheme + (chicken base) + (chicken format) + srfi-69 srfi-99) (include "reflection.scm")) (module protobuf-syntax (int32 int64 uint32 uint64 uint* @@ -89,26 +101,34 @@ bytes string define-enum-type define-message-type define-message-extension) (import - (except scheme string) (except chicken define-record-type) - srfi-69 srfi-99 - protobuf-encoding protobuf-reflection) + (except scheme string) + (chicken base) + srfi-69 srfi-99 + protobuf-encoding protobuf-reflection) + (import-for-syntax + (only (chicken string) conc) + srfi-1) (include "syntax.scm")) (module protobuf (serialize deserialize) (import - scheme (except chicken define-record-type) - srfi-69 srfi-99 - ports extras - protobuf-encoding protobuf-reflection) + 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)) + message? message-extensions message-unknown)) (include "main.scm")) (module protobuf-generic (current-serialization-context make-serialization-context serialization-context? @@ -116,10 +136,19 @@ 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) + 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 Index: protobuf.setup ================================================================== --- protobuf.setup +++ /dev/null @@ -1,37 +0,0 @@ -;; -*- 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"))) Index: protoc-gen-chicken.scm ================================================================== --- protoc-gen-chicken.scm +++ protoc-gen-chicken.scm @@ -8,27 +8,25 @@ ;; files (the Software), to deal in the Software without restriction, ;; including without limitation the rights to use, copy, modify, ;; merge, publish, distribute, sublicense, and/or sell copies of the ;; Software, and to permit persons to whom the Software is furnished ;; to do so, subject to the following conditions: -;; +;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. -;; +;; ;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. -(require-library - srfi-1 srfi-13 srfi-69 - data-structures irregex files ports extras - protobuf) +(import + protobuf) (include "google/protobuf/descriptor.scm") (include "extend/protobuf/bigint.scm") (include "google/protobuf/compiler/plugin.scm") @@ -35,15 +33,23 @@ (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) + 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 - protobuf google-protobuf-compiler protobuf-generator) + google-protobuf-compiler protobuf-generator) (serialize (generate-chicken (deserialize code-generator-request))) + +;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;; Index: reflection.scm ================================================================== --- reflection.scm +++ reflection.scm @@ -8,14 +8,14 @@ ;; 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 @@ -55,14 +55,16 @@ (define (field-info-type v) (force (field-info-type* v))) (define-record-printer (message-info v port) (fprintf port "#" - (type-info-name v) - (hash-table-keys (message-info-fields v)))) + (type-info-name v) + (hash-table-keys (message-info-fields v)))) (define-record-type (message #:uid 'protobuf:message) #f #t extensions (unknown)) (define-record-property prop:protobuf) + +;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;; ADDED srfi-4-comprehensions.scm Index: srfi-4-comprehensions.scm ================================================================== --- /dev/null +++ srfi-4-comprehensions.scm @@ -0,0 +1,252 @@ +;; -*- mode: Scheme; -*- +;; +;; This file is part of Protocol Buffers for CHICKEN +;; Copyright (c) 2018 by Thomas Chust. All rights reserved. +;; +;; Permission is hereby granted, free of charge, to any person +;; obtaining a copy of this software and associated documentation +;; files (the Software), to deal in the Software without restriction, +;; including without limitation the rights to use, copy, modify, +;; merge, publish, distribute, sublicense, and/or sell copies of the +;; Software, and to permit persons to whom the Software is furnished +;; to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +(define-syntax u8vector-of-length-ec + (syntax-rules () + [(u8vector-ec size args ... expr) + (let ([v (make-u8vector size)] [i 0]) + (do-ec args ... + (begin + (u8vector-set! v i expr) + (set! i (+ i 1)))) + v)])) + +(define-syntax u8vector-ec + (syntax-rules () + [(u8vector-ec args ...) + (list->u8vector (list-ec args ...))])) + +(define-syntax :u8vector + (syntax-rules (index) + [(:u8vector cc var (index i) arg) + (:do cc + (let ([v arg])) + ([i 0]) + (fx< i (u8vector-length v)) + (let ([var (u8vector-ref v i)])) + #t + ((fx+ i 1)))] + [(:u8vector cc var arg) + (:u8vector cc var (index i) arg)])) + +(define-syntax s8vector-of-length-ec + (syntax-rules () + [(s8vector-ec size args ... expr) + (let ([v (make-s8vector size)] [i 0]) + (do-ec args ... + (begin + (s8vector-set! v i expr) + (set! i (+ i 1)))) + v)])) + +(define-syntax s8vector-ec + (syntax-rules () + [(s8vector-ec args ...) + (list->s8vector (list-ec args ...))])) + +(define-syntax :s8vector + (syntax-rules (index) + [(:s8vector cc var (index i) arg) + (:do cc + (let ([v arg])) + ([i 0]) + (fx< i (s8vector-length v)) + (let ([var (s8vector-ref v i)])) + #t + ((fx+ i 1)))] + [(:s8vector cc var arg) + (:s8vector cc var (index i) arg)])) + +(define-syntax u16vector-of-length-ec + (syntax-rules () + [(u16vector-ec size args ... expr) + (let ([v (make-u16vector size)] [i 0]) + (do-ec args ... + (begin + (u16vector-set! v i expr) + (set! i (+ i 1)))) + v)])) + +(define-syntax u16vector-ec + (syntax-rules () + [(u16vector-ec args ...) + (list->u16vector (list-ec args ...))])) + +(define-syntax :u16vector + (syntax-rules (index) + [(:u16vector cc var (index i) arg) + (:do cc + (let ([v arg])) + ([i 0]) + (fx< i (u16vector-length v)) + (let ([var (u16vector-ref v i)])) + #t + ((fx+ i 1)))] + [(:u16vector cc var arg) + (:u16vector cc var (index i) arg)])) + +(define-syntax s16vector-of-length-ec + (syntax-rules () + [(s16vector-ec size args ... expr) + (let ([v (make-s16vector size)] [i 0]) + (do-ec args ... + (begin + (s16vector-set! v i expr) + (set! i (+ i 1)))) + v)])) + +(define-syntax s16vector-ec + (syntax-rules () + [(s16vector-ec args ...) + (list->s16vector (list-ec args ...))])) + +(define-syntax :s16vector + (syntax-rules (index) + [(:s16vector cc var (index i) arg) + (:do cc + (let ([v arg])) + ([i 0]) + (fx< i (s16vector-length v)) + (let ([var (s16vector-ref v i)])) + #t + ((fx+ i 1)))] + [(:s16vector cc var arg) + (:s16vector cc var (index i) arg)])) + +(define-syntax u32vector-of-length-ec + (syntax-rules () + [(u32vector-ec size args ... expr) + (let ([v (make-u32vector size)] [i 0]) + (do-ec args ... + (begin + (u32vector-set! v i expr) + (set! i (+ i 1)))) + v)])) + +(define-syntax u32vector-ec + (syntax-rules () + [(u32vector-ec args ...) + (list->u32vector (list-ec args ...))])) + +(define-syntax :u32vector + (syntax-rules (index) + [(:u32vector cc var (index i) arg) + (:do cc + (let ([v arg])) + ([i 0]) + (fx< i (u32vector-length v)) + (let ([var (u32vector-ref v i)])) + #t + ((fx+ i 1)))] + [(:u32vector cc var arg) + (:u32vector cc var (index i) arg)])) + +(define-syntax s32vector-of-length-ec + (syntax-rules () + [(s32vector-ec size args ... expr) + (let ([v (make-s32vector size)] [i 0]) + (do-ec args ... + (begin + (s32vector-set! v i expr) + (set! i (+ i 1)))) + v)])) + +(define-syntax s32vector-ec + (syntax-rules () + [(s32vector-ec args ...) + (list->s32vector (list-ec args ...))])) + +(define-syntax :s32vector + (syntax-rules (index) + [(:s32vector cc var (index i) arg) + (:do cc + (let ([v arg])) + ([i 0]) + (fx< i (s32vector-length v)) + (let ([var (s32vector-ref v i)])) + #t + ((fx+ i 1)))] + [(:s32vector cc var arg) + (:s32vector cc var (index i) arg)])) + +(define-syntax u64vector-of-length-ec + (syntax-rules () + [(u64vector-ec size args ... expr) + (let ([v (make-u64vector size)] [i 0]) + (do-ec args ... + (begin + (u64vector-set! v i expr) + (set! i (+ i 1)))) + v)])) + +(define-syntax u64vector-ec + (syntax-rules () + [(u64vector-ec args ...) + (list->u64vector (list-ec args ...))])) + +(define-syntax :u64vector + (syntax-rules (index) + [(:u64vector cc var (index i) arg) + (:do cc + (let ([v arg])) + ([i 0]) + (fx< i (u64vector-length v)) + (let ([var (u64vector-ref v i)])) + #t + ((fx+ i 1)))] + [(:u64vector cc var arg) + (:u64vector cc var (index i) arg)])) + +(define-syntax s64vector-of-length-ec + (syntax-rules () + [(s64vector-ec size args ... expr) + (let ([v (make-s64vector size)] [i 0]) + (do-ec args ... + (begin + (s64vector-set! v i expr) + (set! i (+ i 1)))) + v)])) + +(define-syntax s64vector-ec + (syntax-rules () + [(s64vector-ec args ... expr) + (blob->s64vector/shared + (u64vector->blob/shared + (list->u64vector (list-ec args ... (modulo expr #x10000000000000000)))))])) + +(define-syntax :s64vector + (syntax-rules (index) + [(:s64vector cc var (index i) arg) + (:do cc + (let ([v arg])) + ([i 0]) + (fx< i (s64vector-length v)) + (let ([var (s64vector-ref v i)])) + #t + ((fx+ i 1)))] + [(:s64vector cc var arg) + (:s64vector cc var (index i) arg)])) + +;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;; Index: syntax.scm ================================================================== --- syntax.scm +++ syntax.scm @@ -8,14 +8,14 @@ ;; 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 @@ -76,21 +76,21 @@ [(define-enum-type name (alt tag) ...) (define name (make-enum-info - 'name - (lambda (int) - (case int - [(tag) 'alt] - ... - [else (syntax-error 'name "unknown enumeration tag" int)])) - (lambda (sym) - (case sym - [(alt) tag] - ... - [else (syntax-error 'name "unknown enumeration value" sym)]))))])) + 'name + (lambda (int) + (case int + [(tag) 'alt] + ... + [else (syntax-error 'name "unknown enumeration tag" int)])) + (lambda (sym) + (case sym + [(alt) tag] + ... + [else (syntax-error 'name "unknown enumeration value" sym)]))))])) (define-syntax %message-field-label (syntax-rules (required optional repeated packed) ;; packed? -------\ ;; repeated? ----\ | @@ -113,11 +113,11 @@ (cons* (rename 'define-values) (map string->symbol (list (conc "make-" (cadr stx)) - (conc (cadr stx) "?"))) + (conc (cadr stx) "?"))) (cddr stx))))) (define-syntax %define-message-accessor+mutator (er-macro-transformer (lambda (stx rename compare) @@ -124,101 +124,103 @@ (cons* (rename 'define-values) (map string->symbol (list (conc (cadr stx) "-" (caddr stx)) - (conc (cadr stx) "-" (caddr stx) "-set!"))) + (conc (cadr stx) "-" (caddr stx) "-set!"))) (cdddr stx))))) (define-syntax define-message-type (syntax-rules () [(define-message-type name (label type field tag . default) ...) (begin (define name - (letrec ([name - (make-rtd - 'name '#((mutable field) ...) - #:parent message - #:property prop:protobuf (lambda _ descriptor))] - [descriptor - (void)]) - (set! descriptor - (make-message-info - 'name - (let ([constructor* (rtd-constructor name)]) - (lambda (#!key [field ((%message-field-default . default))] ...) - (constructor* - (make-hash-table eqv? eqv?-hash) "" - field ...))) - (make-hash-table eqv? eqv?-hash) - (make-hash-table eqv? eqv?-hash))) - (let-values ([(required? repeated? packed?) - (%message-field-label label)] - [(accessor mutator) - (values - (let ([accessor* (rtd-accessor name 'field)]) - (lambda (msg #!optional [v* (%message-field-default . default)]) - (let ([v (accessor* msg)]) - (if (eq? v (void)) - (if (procedure? v*) (v*) v*) - v)))) - (rtd-mutator name 'field))]) - (hash-table-set! - (message-info-fields descriptor) tag - (make-field-info - (delay type) repeated? packed? - (getter-with-setter accessor mutator) mutator)) - (when required? - (hash-table-set! - (message-info-required descriptor) tag - #t))) - ... - name)) + (letrec ([name + (make-rtd + 'name '#((mutable field) ...) + #:parent message + #:property prop:protobuf (lambda _ descriptor))] + [descriptor + (void)]) + (set! descriptor + (make-message-info + 'name + (let ([constructor* (rtd-constructor name)]) + (lambda (#!key [field ((%message-field-default . default))] ...) + (constructor* + (make-hash-table eqv? eqv?-hash) "" + field ...))) + (make-hash-table eqv? eqv?-hash) + (make-hash-table eqv? eqv?-hash))) + (let-values ([(required? repeated? packed?) + (%message-field-label label)] + [(accessor mutator) + (values + (let ([accessor* (rtd-accessor name 'field)]) + (lambda (msg #!optional [v* (%message-field-default . default)]) + (let ([v (accessor* msg)]) + (if (eq? v (void)) + (if (procedure? v*) (v*) v*) + v)))) + (rtd-mutator name 'field))]) + (hash-table-set! + (message-info-fields descriptor) tag + (make-field-info + (delay type) repeated? packed? + (getter-with-setter accessor mutator) mutator)) + (when required? + (hash-table-set! + (message-info-required descriptor) tag + #t))) + ... + name)) (%define-message-constructor+predicate name (values (message-info-constructor (prop:protobuf #f name)) - (rtd-predicate name))) + (rtd-predicate name))) (%define-message-accessor+mutator name field - (let ([descriptor - (hash-table-ref - (message-info-fields (prop:protobuf #f name)) tag)]) - (values (field-info-accessor descriptor) - (field-info-mutator descriptor)))) + (let ([descriptor + (hash-table-ref + (message-info-fields (prop:protobuf #f name)) tag)]) + (values (field-info-accessor descriptor) + (field-info-mutator descriptor)))) ...)])) (define-syntax define-message-extension (syntax-rules () [(define-message-extension name (label type field tag . default) ...) (begin (let-values ([(descriptor) - (prop:protobuf #f name)] - [(required? repeated? packed?) - (%message-field-label label)] - [(accessor mutator) - (values - (lambda (msg #!optional [v* (%message-field-default . default)]) - (hash-table-ref - (message-extensions msg) tag v*)) - (lambda (msg v) - (hash-table-set! - (message-extensions msg) tag - v)))]) - (hash-table-set! - (message-info-fields descriptor) tag - (make-field-info - (delay type) repeated? packed? - (getter-with-setter accessor mutator) mutator)) - (when required? - (hash-table-set! - (message-info-required descriptor) tag - #t))) + (prop:protobuf #f name)] + [(required? repeated? packed?) + (%message-field-label label)] + [(accessor mutator) + (values + (lambda (msg #!optional [v* (%message-field-default . default)]) + (hash-table-ref + (message-extensions msg) tag v*)) + (lambda (msg v) + (hash-table-set! + (message-extensions msg) tag + v)))]) + (hash-table-set! + (message-info-fields descriptor) tag + (make-field-info + (delay type) repeated? packed? + (getter-with-setter accessor mutator) mutator)) + (when required? + (hash-table-set! + (message-info-required descriptor) tag + #t))) ... (%define-message-accessor+mutator name field - (let ([descriptor - (hash-table-ref - (message-info-fields (prop:protobuf #f name)) tag)]) - (values (field-info-accessor descriptor) - (field-info-mutator descriptor)))) + (let ([descriptor + (hash-table-ref + (message-info-fields (prop:protobuf #f name)) tag)]) + (values (field-info-accessor descriptor) + (field-info-mutator descriptor)))) ...)])) + +;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;; Index: tests/abook.scm ================================================================== --- tests/abook.scm +++ tests/abook.scm @@ -1,10 +1,10 @@ -;; Generated by protoc-gen-chicken v1.0.0 +;; Generated by protoc-gen-chicken v1.1.3 (module abook * - (import (except scheme string) chicken protobuf-syntax) + (import (except scheme string) (chicken base) protobuf-syntax) (define-enum-type person:phone-type (mobile 0) (home 1) (work 2)) (define-message-type person:phone-number (required string number 1) (optional person:phone-type type 2 'home)) Index: tests/generic.scm ================================================================== --- tests/generic.scm +++ tests/generic.scm @@ -8,14 +8,14 @@ ;; 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 @@ -22,11 +22,11 @@ ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. (define-record-type (foo - #:uid '4b9aa808-96ef-48e3-bb97-d71f37068fe1) + #:uid '4b9aa808-96ef-48e3-bb97-d71f37068fe1) #t #t a b) (define (read-bar port) (make-bar (read-string #f port))) @@ -33,94 +33,116 @@ (define (write-bar v port) (write-string (bar-ref v) #f port)) (define-record-type (bar - #:property prop:serialization-info - (make-serialization-info read-bar write-bar)) + #:property prop:serialization-info + (make-serialization-info read-bar write-bar)) #t #t ref) (define (serialize+deserialize v) (call-with-input-string (call-with-output-string (cut serialize v <>)) deserialize)) -(define (check-invariance v #!optional [test equal?]) - (check (serialize+deserialize v) (=> test) v)) - -(define (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 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!"))) +(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) + (stringalist + (serialize+deserialize + (alist->hash-table lst0))) + (lambda (a b) + (< (car a) (car b))))]) + (test lst0 lst1))) + + (test-group "procedures" + (test 84 ((serialize+deserialize mul42) 2))) + + (test-group "homogeneous blobs" + (test-invariance '#u8(1 2 3)) + (test-invariance '#s8(-1 0 +1)) + (test-invariance '#u16(1 2 3)) + (test-invariance '#s16(-1 0 +1)) + (test-invariance '#u32(1 2 3)) + (test-invariance '#s32(-1 0 +1)) + (test-invariance '#u64(1 2 3)) + (test-invariance '#s64(-1 0 +1)) + (test-invariance '#f32(1.234 5.678)) + (test-invariance '#f64(1.234 5.678)) + (test-invariance '#${983729423476237887246302})) + + (test-group "records" + (test-invariance (make-foo 42+23i "Hallo Welt!")) + (test-invariance (make-bar "kawumm!"))) + + )) + +;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;; Index: tests/main.scm ================================================================== --- tests/main.scm +++ tests/main.scm @@ -8,22 +8,24 @@ ;; files (the Software), to deal in the Software without restriction, ;; including without limitation the rights to use, copy, modify, ;; merge, publish, distribute, sublicense, and/or sell copies of the ;; Software, and to permit persons to whom the Software is furnished ;; to do so, subject to the following conditions: -;; +;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. -;; +;; ;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. + +(define packed-fields-message-bytes #${0A0503010401051203010405}) (define (message-rtd? v) (and (rtd? v) (message-info? (prop:protobuf #f v)))) (define msg @@ -42,57 +44,90 @@ (make-person:phone-number #:number "+67-876743724-8751751" #:type 'mobile) (make-person:phone-number #:number "+60-9848752576-987832" #:type 'work)))))) -(define (check-structure msg) - (check (message? msg) => #t) - (check (address-book? msg) => #t) +(define (test-structure msg) + (test-assert (message? msg)) + (test-assert (address-book? msg)) (let ([persons (address-book-person msg '())]) - (check (length persons) => 2) + (test 2 (length persons)) (let ([jane (first persons)] - [joe (second persons)]) - (check (person? jane) => #t) - (check (person-id jane) => 42) - (check (person-name jane) => "Jane Doe") - (check (person-email jane) => (void)) - (check (person-email jane "jane@example.com") => "jane@example.com") + [joe (second persons)]) + (test-assert (person? jane)) + (test 42 (person-id jane)) + (test "Jane Doe" (person-name jane)) + (test (void) (person-email jane)) + (test "jane@example.com" (person-email jane "jane@example.com")) (let ([phones (person-phone jane)]) - (check (length phones) => 1) - (let ([phone (car phones)]) - (check (person:phone-number-number phone) => "+12-3456-7890") - (check (person:phone-number-type phone) => 'home))) - - (check (person? joe) => #t) - (check (person-id joe) => 23) - (check (person-name joe) => "Johannes Mustermann") - (check (person-email joe) => "joe@example.com") - (check (person-email joe "whatever@example.com") => "joe@example.com") + (test 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)]) - (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)) + (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))))) + (test-group "reading message with packed fields" + (let + ((message + (call-with-input-string + (blob->string packed-fields-message-bytes) + (cut deserialize packed-message <>)))) + (test '(3 1 4 1 5) (packed-message-nums message)) + (test + '(green brown grey) + (packed-message-ranked-bikeshed-preferences message)))) + + (test-group "round-trip message with packed fields" + (let* ((original + (make-packed-message + #:nums '(1 3 5 7 9) + #:ranked-bikeshed-preferences '(grey blue))) + (new (call-with-input-string + (call-with-output-string (cut serialize original <>)) + (cut deserialize packed-message <>)))) + (test (packed-message-nums original) (packed-message-nums new)) + (test + (packed-message-ranked-bikeshed-preferences original) + (packed-message-ranked-bikeshed-preferences new)))) + + )) + +;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;; ADDED tests/packing.proto Index: tests/packing.proto ================================================================== --- /dev/null +++ tests/packing.proto @@ -0,0 +1,38 @@ +// This file is part of Protocol Buffers for CHICKEN +// Copyright (c) 2013 by Thomas Chust. All rights reserved. +// Copyright (c) 2022 by Chris Brannon. All rights reserved. +// +// Permission is hereby granted, free of charge, to any person +// obtaining a copy of this software and associated documentation +// files (the Software), to deal in the Software without restriction, +// including without limitation the rights to use, copy, modify, +// merge, publish, distribute, sublicense, and/or sell copies of the +// Software, and to permit persons to whom the Software is furnished +// to do so, subject to the following conditions: +// +// The above copyright notice and this permission notice shall be +// included in all copies or substantial portions of the Software. +// +// THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, +// EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +// MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +// NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +// BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +// ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +// CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +// SOFTWARE. +package packing; + +enum Color { + RED = 0; + GREEN = 1; + BLUE = 2; + ORANGE = 3; + BROWN = 4; + GREY = 5; +} + +message PackedMessage { + repeated uint64 nums = 1 [packed = true]; + repeated Color ranked_bikeshed_preferences = 2 [packed = true]; +} ADDED tests/packing.scm Index: tests/packing.scm ================================================================== --- /dev/null +++ tests/packing.scm @@ -0,0 +1,17 @@ +;; Generated by protoc-gen-chicken v1.1.3 +(module + packing + * + (import (except scheme string) (chicken base) protobuf-syntax) + (define-enum-type + color + (red 0) + (green 1) + (blue 2) + (orange 3) + (brown 4) + (grey 5)) + (define-message-type + packed-message + (packed uint64 nums 1) + (packed color ranked-bikeshed-preferences 2))) Index: tests/run.scm ================================================================== --- tests/run.scm +++ tests/run.scm @@ -8,53 +8,57 @@ ;; files (the Software), to deal in the Software without restriction, ;; including without limitation the rights to use, copy, modify, ;; merge, publish, distribute, sublicense, and/or sell copies of the ;; Software, and to permit persons to whom the Software is furnished ;; to do so, subject to the following conditions: -;; +;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. -;; +;; ;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. -(require-library - srfi-1 srfi-78 srfi-99 - data-structures ports extras - protobuf) +(import + protobuf test) (include "abook.scm") +(include "packing.scm") -(module tests-main - (run) +(module test-main + (test-main) (import - scheme (except chicken define-record-type) - srfi-1 srfi-78 srfi-99 - ports - protobuf protobuf-reflection abook) + scheme + (chicken base) + (chicken blob) + (chicken port) + srfi-1 srfi-99 + protobuf protobuf-reflection abook packing test) (include "main.scm")) -(module tests-generic - (run) +(module test-generic + (test-generic) (import - scheme (except chicken define-record-type) - srfi-1 srfi-69 srfi-78 srfi-99 - data-structures ports extras - protobuf-generic) + scheme + (chicken base) + (chicken sort) + (chicken io) + (chicken port) + (chicken format) + srfi-1 srfi-69 srfi-99 + protobuf-generic test) (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)) + test-main test-generic) + +(test-main) +(test-generic) + +(test-exit) + +;; vim: set ai et ts=8 sts=2 sw=2 ft=scheme: ;;