Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | imported v1.0.0 |
---|---|
Downloads: | Tarball | ZIP archive |
Timelines: | family | ancestors | descendants | both | trunk | v1.0.0 |
Files: | files | file ages | folders |
SHA3-256: |
8e6feddb9633ef3cef0569b531e2274e |
User & Date: | murphy 2018-08-18 20:02:54.042 |
Context
2018-08-18
| ||
20:03 | imported v1.0.1 check-in: 216ffb08b7 user: murphy tags: trunk, v1.0.1 | |
20:02 | imported v1.0.0 check-in: 8e6feddb96 user: murphy tags: trunk, v1.0.0 | |
20:01 | initial empty check-in check-in: fd5fd1da28 user: murphy tags: trunk | |
Changes
Added LICENSE.txt.
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | Copyright (C) 2011-2013 Thomas Chust <chust@web.de>. All rights reserved. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the Software), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 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. |
Added encoding.scm.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 | ;; -*- mode: Scheme; -*- ;; ;; This file is part of Protocol Buffers for CHICKEN ;; Copyright (c) 2013 by Thomas Chust. All rights reserved. ;; ;; Permission is hereby granted, free of charge, to any person ;; obtaining a copy of this software and associated documentation ;; files (the Software), to deal in the Software without restriction, ;; including without limitation the rights to use, copy, modify, ;; merge, publish, distribute, sublicense, and/or sell copies of the ;; Software, and to permit persons to whom the Software is furnished ;; to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. (define (make-limited-input-port in limit close-orig?) (make-input-port #;read (lambda () (if (fx> limit 0) (begin (set! limit (fx- limit 1)) (read-char in)) #!eof)) #;ready? (lambda () (and (fx> limit 0) (char-ready? in))) #;close (lambda () (if close-orig? (close-input-port in) (void))) #;peek (lambda () (if (fx> limit 0) (peek-char in) #!eof)))) (define (read-uint* #!optional [port (current-input-port)] [max-size 10]) (let loop ([span 0]) (if (and max-size (>= span max-size)) (syntax-error 'read-uint* "maximum integer size exceeded" max-size) (let ((b (read-byte port))) (if (and (not (eof-object? b)) (bit-set? b 7)) (+ (bitwise-and b #x7f) (* 128 (loop (add1 span)))) b))))) (define (write-uint* n #!optional [port (current-output-port)] [max-size 10]) (let loop ([n n] [span 0]) (if (and max-size (>= span max-size)) (syntax-error 'write-uint* "maximum integer size exceeded" max-size) (let*-values ([(r b) (quotient&remainder n 128)] [(last?) (zero? r)]) (write-byte (if last? b (bitwise-ior #x80 b)) port) (unless last? (loop r (add1 span))))))) (define (read-sint* #!optional [port (current-input-port)] [max-size 10]) (let ([z (read-uint* port max-size)]) (if (eof-object? z) z (/ (if (odd? z) (- -1 z) z) 2)))) (define (write-sint* i #!optional [port (current-output-port)] [max-size 10]) (let ([2i (* 2 i)]) (write-uint* (if (negative? i) (- -1 2i) 2i) port max-size))) (define (read-int* #!optional [port (current-input-port)]) (let ([n (read-uint* port)]) (if (eof-object? n) n (if (positive? (- n #x8000000000000000)) (- n #x10000000000000000) n)))) (define (write-int* i #!optional [port (current-output-port)]) (write-uint* (if (negative? i) (+ i #x10000000000000000) i) port)) (define (read-bool #!optional [port (current-input-port)]) (let ([n (read-uint* port)]) (if (eof-object? n) n (not (zero? n))))) (define (write-bool v #!optional [port (current-output-port)]) (write-uint* (if v 1 0) port)) (define ((read-fixed* size signed?) #!optional [port (current-input-port)]) (let ([bstr (read-u8vector size port)]) (if (eof-object? bstr) bstr (let ([span (u8vector-length bstr)]) (if (< span size) (syntax-error 'read-fixed* "found truncated fixed integer bytes") (let ([unsigned (sum-ec (:u8vector b (index i) bstr) (arithmetic-shift b (fx* i 8)))]) (if (and signed? (bit-set? unsigned (fx- (fx* size 8) 1))) (- unsigned (arithmetic-shift 1 (fx* size 8))) unsigned))))))) (define read-fixed32 (read-fixed* 4 #f)) (define read-fixed64 (read-fixed* 8 #f)) (define read-sfixed32 (read-fixed* 4 #t)) (define read-sfixed64 (read-fixed* 8 #t)) (define ((write-fixed* size signed?) n #!optional [port (current-output-port)]) (let* ([unsigned (if (and signed? (negative? n)) (+ (arithmetic-shift 1 (fx* size 8)) n) n)] [bstr (u8vector-of-length-ec size (:range i size) (bitwise-and (arithmetic-shift unsigned (fx* i -8)) #xff))]) (write-u8vector bstr port))) (define write-fixed32 (write-fixed* 4 #f)) (define write-fixed64 (write-fixed* 8 #f)) (define write-sfixed32 (write-fixed* 4 #t)) (define write-sfixed64 (write-fixed* 8 #t)) (define ((read-float* size) #!optional [port (current-input-port)]) (let ([bstr (read-u8vector size port)]) (if (eof-object? bstr) bstr (let ([span (u8vector-length bstr)]) (cond ((< span size) (syntax-error 'read-float* "found truncated fixed floating point bytes")) ((= size 8) (f64vector-ref (blob->f64vector/shared (u8vector->blob/shared bstr)) 0)) ((= size 4) (f32vector-ref (blob->f32vector/shared (u8vector->blob/shared bstr)) 0)) (else (error 'read-float* "only 64-bit and 32-bit floating point values are supported"))))))) (define read-float (read-float* 4)) (define read-double (read-float* 8)) (define ((write-float* size) x #!optional [port (current-output-port)]) (write-u8vector (blob->u8vector/shared (cond ((= size 8) (f64vector->blob/shared (f64vector x))) ((= size 4) (f32vector->blob/shared (f32vector x))) (else (error 'write-float* "only 64-bit and 32-bit floating point values are supported")))) port)) (define write-float (write-float* 4)) (define write-double (write-float* 8)) (define (read-sized-bytes #!optional [port (current-input-port)]) (let ([size (read-uint* port)]) (if (eof-object? size) size (let ([bstr (read-u8vector size port)]) (if (or (eof-object? bstr) (< (string-length bstr) size)) (syntax-error 'read-sized-bytes "found truncated bytes") bstr))))) (define (write-sized-bytes bstr #!optional [port (current-output-port)]) (write-uint* (u8vector-length bstr) port) (write-u8vector bstr port)) (define (read-sized-string #!optional [port (current-input-port)]) (let ([size (read-uint* port)]) (if (eof-object? size) size (let ([bstr (read-string size port)]) (if (or (eof-object? bstr) (< (string-length bstr) size)) (syntax-error 'read-sized-string "found truncated bytes") bstr))))) (define (write-sized-string bstr #!optional [port (current-output-port)]) (write-uint* (string-length bstr) port) (write-string bstr #f port)) (define (read-sized read #!optional [port (current-input-port)]) (let ([size (read-uint* port)]) (if (eof-object? size) size (let ([v (read (make-limited-input-port port size #f))]) (if (eof-object? v) (syntax-error 'read-sized "found truncated data") v))))) (define (write-sized write v #!optional [port (current-output-port)]) (let ([bstr (call-with-output-string (cut write v <>))]) (write-uint* (string-length bstr) port) (write-string bstr #f port))) (define (read-tag/type #!optional [port (current-input-port)]) (let ([tag/type (read-uint* port)]) (if (eof-object? tag/type) (values tag/type tag/type) (values (arithmetic-shift tag/type -3) (let ([type (bitwise-and tag/type #b111)]) (case type [(0) 'int*] [(1) '64bit] [(5) '32bit] [(2) 'sized] [else (syntax-error 'read-tag/type "found unknown field type" type)])))))) (define (write-tag/type tag type #!optional [port (current-output-port)]) (write-uint* (bitwise-ior (arithmetic-shift tag 3) (case type [(int*) 0] [(64bit) 1] [(32bit) 5] [(sized) 2])) port)) |
Added extend/protobuf/bigint.proto.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | // This file is part of Protocol Buffers for CHICKEN // Copyright (c) 2013 by Thomas Chust. All rights reserved. // // Permission is hereby granted, free of charge, to any person // obtaining a copy of this software and associated documentation // files (the Software), to deal in the Software without restriction, // including without limitation the rights to use, copy, modify, // merge, publish, distribute, sublicense, and/or sell copies of the // Software, and to permit persons to whom the Software is furnished // to do so, subject to the following conditions: // // The above copyright notice and this permission notice shall be // included in all copies or substantial portions of the Software. // // THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, // EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF // MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND // NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS // BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN // ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN // CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE // SOFTWARE. package extend.protobuf; import "google/protobuf/descriptor.proto"; extend google.protobuf.FieldOptions { // Explicitly changes the ten byte size restriction for uint64 or // sint64 types to allow big integers. If set to zero, the size of // the type is not limited. optional uint32 max_size = 76884 [default = 10]; } |
Added extend/protobuf/bigint.scm.
> > > > > > | 1 2 3 4 5 6 | ;; Generated by protoc-gen-chicken v1.0.0 (module extend-protobuf * (import (except scheme string) chicken protobuf-syntax google-protobuf) (define-message-extension field-options (optional uint32 max-size 76884 10))) |
Added generator.scm.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 | ;; -*- mode: Scheme; -*- ;; ;; This file is part of Protocol Buffers for CHICKEN ;; Copyright (c) 2013 by Thomas Chust. All rights reserved. ;; ;; Permission is hereby granted, free of charge, to any person ;; obtaining a copy of this software and associated documentation ;; files (the Software), to deal in the Software without restriction, ;; including without limitation the rights to use, copy, modify, ;; merge, publish, distribute, sublicense, and/or sell copies of the ;; Software, and to permit persons to whom the Software is furnished ;; to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. (define make-identifier (let ([camel (sre->irregex '(: ($ lower) ($ upper)))] [score (sre->irregex '("._"))]) (lambda (str #!optional prefix) (string->symbol (conc (or prefix "") (if prefix ":" "") (string-downcase (irregex-replace/all score (irregex-replace/all camel str 1 "-" 2) "-"))))))) (define (proto-file-register! types file) (define name (file-descriptor-proto-package file "main")) (define module (make-identifier name)) (define (register-identifier! path name prefix) (let ([path (string-append path "." name)] [prefix (make-identifier name prefix)]) (hash-table-set! types path (cons module prefix)) (values path prefix))) (define (register-enum! path enum #!optional prefix) (register-identifier! path (enum-descriptor-proto-name enum) prefix)) (define (register-message! path msg #!optional prefix) (let-values ([(path prefix) (register-identifier! path (descriptor-proto-name msg) prefix)]) (for-each (cut register-enum! path <> prefix) (descriptor-proto-enum-type msg '())) (for-each (cut register-message! path <> prefix) (descriptor-proto-nested-type msg '())))) (let ([path (string-append "." name)]) (for-each (cut register-enum! path <>) (file-descriptor-proto-enum-type file '())) (for-each (cut register-message! path <>) (file-descriptor-proto-message-type file '())))) (define (proto-file-translate types file) (define module (make-identifier (file-descriptor-proto-package file "main"))) (define imports (make-hash-table eq? symbol-hash)) (define (resolve-identifier! name prefix) (let-values ([(module symbol) (car+cdr (hash-table-ref types name (cut error prefix "unknown type" name)))]) (hash-table-set! imports module #t) symbol)) (define (translate-enum-definition enum #!optional prefix) (let ([name (make-identifier (enum-descriptor-proto-name enum) prefix)]) `((define-enum-type ,name ,@(map (lambda (item) (list (make-identifier (enum-value-descriptor-proto-name item)) (enum-value-descriptor-proto-number item))) (enum-descriptor-proto-value enum '())))))) (define (translate-field field prefix) (let ([name (make-identifier (field-descriptor-proto-name field))] [options (field-descriptor-proto-options field make-field-options)]) (cons* (case (field-descriptor-proto-label field) [(label-required) 'required] [(label-optional) 'optional] [(label-repeated) (if (field-options-packed options #f) 'packed 'repeated)]) (case (field-descriptor-proto-type field) [(type-int32) 'int32] [(type-int64) 'int64] [(type-uint32) 'uint32] [(type-uint64) (let ([max-size (field-options-max-size options)]) (if (= max-size 10) 'uint64 `(uint* ,(and (positive? max-size) max-size))))] [(type-sint32) 'sint32] [(type-sint64) (let ([max-size (field-options-max-size options)]) (if (= max-size 10) 'sint64 `(sint* ,(and (positive? max-size) max-size))))] [(type-fixed32) 'fixed32] [(type-fixed64) 'fixed64] [(type-sfixed32) 'sfixed32] [(type-sfixed64) 'sfixed64] [(type-bool) 'bool] [(type-float) 'float] [(type-double) 'double] [(type-bytes) 'bytes] [(type-string) 'string] [else (resolve-identifier! (field-descriptor-proto-type-name field) name)]) name (field-descriptor-proto-number field) (let ([default (field-descriptor-proto-default-value field void)]) (if (eq? default (void)) '() (list (case (field-descriptor-proto-type field) [(type-int32 type-int64 type-uint32 type-uint64 type-sint32 type-sint64 type-fixed32 type-fixed64 type-sfixed32 type-sfixed64 type-float type-double type-bytes) (call-with-input-string default read)] [(type-bool) (not (equal? default "false"))] [(type-enum) `(quote ,(make-identifier default))] [(type-string) default] [else (error prefix "unsupported default value" name default)]))))))) (define (translate-message-definition msg #!optional prefix) (let ([name (make-identifier (descriptor-proto-name msg) prefix)]) (append (append-map (cut translate-enum-definition <> name) (descriptor-proto-enum-type msg '())) (append-map (cut translate-message-definition <> name) (descriptor-proto-nested-type msg '())) (append-map translate-message-extension (descriptor-proto-extension msg '())) `((define-message-type ,name ,@(map (cut translate-field <> name) (descriptor-proto-field msg '()))))))) (define (translate-message-extension ext) (let ([name (resolve-identifier! (field-descriptor-proto-extendee ext) '<message-extension>)]) `((define-message-extension ,name ,(translate-field ext name))))) (define body (append (append-map translate-enum-definition (file-descriptor-proto-enum-type file '())) (append-map translate-message-definition (file-descriptor-proto-message-type file '())) (append-map translate-message-extension (file-descriptor-proto-extension file '())))) (hash-table-delete! imports module) (make-code-generator-response:file #:name (pathname-replace-extension (file-descriptor-proto-name file) "scm") #:content (call-with-output-string (lambda (port) (display ";; Generated by protoc-gen-chicken v1.0.0" port) (newline port) (pretty-print `(module ,module * (import (except scheme string) chicken protobuf-syntax ,@(hash-table-keys imports)) ,@body) port))))) (define (generate-chicken request) (define files (make-hash-table string=? string-hash)) (define types (make-hash-table string=? string-hash)) (for-each (lambda (file) (hash-table-set! files (file-descriptor-proto-name file) file) (proto-file-register! types file)) (code-generator-request-proto-file request '())) (condition-case (make-code-generator-response #:file (map (lambda (name) (proto-file-translate types (hash-table-ref files name))) (code-generator-request-file-to-generate request '()))) [exn (exn) (make-code-generator-response #:error (call-with-output-string (cut print-error-message exn <>)))])) |
Added google/protobuf/compiler/plugin.scm.
> > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | ;; Generated by protoc-gen-chicken v1.0.0 (module google-protobuf-compiler * (import (except scheme string) chicken protobuf-syntax google-protobuf) (define-message-type code-generator-request (repeated string file-to-generate 1) (optional string parameter 2) (repeated file-descriptor-proto proto-file 15)) (define-message-type code-generator-response:file (optional string name 1) (optional string insertion-point 2) (optional string content 15)) (define-message-type code-generator-response (optional string error 1) (repeated code-generator-response:file file 15))) |
Added google/protobuf/descriptor.scm.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 | ;; Generated by protoc-gen-chicken v1.0.0 (module google-protobuf * (import (except scheme string) chicken protobuf-syntax) (define-message-type file-descriptor-set (repeated file-descriptor-proto file 1)) (define-message-type file-descriptor-proto (optional string name 1) (optional string package 2) (repeated string dependency 3) (repeated descriptor-proto message-type 4) (repeated enum-descriptor-proto enum-type 5) (repeated service-descriptor-proto service 6) (repeated field-descriptor-proto extension 7) (optional file-options options 8) (optional source-code-info source-code-info 9)) (define-message-type descriptor-proto:extension-range (optional int32 start 1) (optional int32 end 2)) (define-message-type descriptor-proto (optional string name 1) (repeated field-descriptor-proto field 2) (repeated field-descriptor-proto extension 6) (repeated descriptor-proto nested-type 3) (repeated enum-descriptor-proto enum-type 4) (repeated descriptor-proto:extension-range extension-range 5) (optional message-options options 7)) (define-enum-type field-descriptor-proto:type (type-double 1) (type-float 2) (type-int64 3) (type-uint64 4) (type-int32 5) (type-fixed64 6) (type-fixed32 7) (type-bool 8) (type-string 9) (type-group 10) (type-message 11) (type-bytes 12) (type-uint32 13) (type-enum 14) (type-sfixed32 15) (type-sfixed64 16) (type-sint32 17) (type-sint64 18)) (define-enum-type field-descriptor-proto:label (label-optional 1) (label-required 2) (label-repeated 3)) (define-message-type field-descriptor-proto (optional string name 1) (optional int32 number 3) (optional field-descriptor-proto:label label 4) (optional field-descriptor-proto:type type 5) (optional string type-name 6) (optional string extendee 2) (optional string default-value 7) (optional field-options options 8)) (define-message-type enum-descriptor-proto (optional string name 1) (repeated enum-value-descriptor-proto value 2) (optional enum-options options 3)) (define-message-type enum-value-descriptor-proto (optional string name 1) (optional int32 number 2) (optional enum-value-options options 3)) (define-message-type service-descriptor-proto (optional string name 1) (repeated method-descriptor-proto method 2) (optional service-options options 3)) (define-message-type method-descriptor-proto (optional string name 1) (optional string input-type 2) (optional string output-type 3) (optional method-options options 4)) (define-enum-type file-options:optimize-mode (speed 1) (code-size 2) (lite-runtime 3)) (define-message-type file-options (optional string java-package 1) (optional string java-outer-classname 8) (optional bool java-multiple-files 10 #f) (optional bool java-generate-equals-and-hash 20 #f) (optional file-options:optimize-mode optimize-for 9 'speed) (optional bool cc-generic-services 16 #f) (optional bool java-generic-services 17 #f) (optional bool py-generic-services 18 #f) (repeated uninterpreted-option uninterpreted-option 999)) (define-message-type message-options (optional bool message-set-wire-format 1 #f) (optional bool no-standard-descriptor-accessor 2 #f) (repeated uninterpreted-option uninterpreted-option 999)) (define-enum-type field-options:ctype (string 0) (cord 1) (string-piece 2)) (define-message-type field-options (optional field-options:ctype ctype 1 'string) (optional bool packed 2) (optional bool deprecated 3 #f) (optional string experimental-map-key 9) (repeated uninterpreted-option uninterpreted-option 999)) (define-message-type enum-options (repeated uninterpreted-option uninterpreted-option 999)) (define-message-type enum-value-options (repeated uninterpreted-option uninterpreted-option 999)) (define-message-type service-options (repeated uninterpreted-option uninterpreted-option 999)) (define-message-type method-options (repeated uninterpreted-option uninterpreted-option 999)) (define-message-type uninterpreted-option:name-part (required string name-part 1) (required bool is-extension 2)) (define-message-type uninterpreted-option (repeated uninterpreted-option:name-part name 2) (optional string identifier-value 3) (optional uint64 positive-int-value 4) (optional int64 negative-int-value 5) (optional double double-value 6) (optional bytes string-value 7) (optional string aggregate-value 8)) (define-message-type source-code-info:location (packed int32 path 1) (packed int32 span 2)) (define-message-type source-code-info (repeated source-code-info:location location 1))) |
Added main.scm.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 | ;; -*- mode: Scheme; -*- ;; ;; This file is part of Protocol Buffers for CHICKEN ;; Copyright (c) 2013 by Thomas Chust. All rights reserved. ;; ;; Permission is hereby granted, free of charge, to any person ;; obtaining a copy of this software and associated documentation ;; files (the Software), to deal in the Software without restriction, ;; including without limitation the rights to use, copy, modify, ;; merge, publish, distribute, sublicense, and/or sell copies of the ;; Software, and to permit persons to whom the Software is furnished ;; to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. (define ((appender accessor mutator) msg v) (mutator msg (append (accessor msg '()) (if (list? v) v (list v))))) (define (deserialize type #!optional [port (current-input-port)]) (let ([info (prop:protobuf #f type)]) (letrec ([msg ((message-info-constructor info))] [fields (message-info-fields info)] [required (hash-table-copy (message-info-required info))] [unknown (open-output-string)]) (let loop () (let-values ([(tag type) (read-tag/type port)]) (unless (or (eof-object? tag) (eof-object? type)) (hash-table-delete! required tag) (cond [(hash-table-ref/default fields tag #f) => (lambda (field) (let* ([ftype (field-info-type field)] [repeated? (field-info-repeated? field)] [accessor (field-info-accessor field)] [mutator (field-info-mutator field)] [updator (if repeated? (appender accessor mutator) mutator)]) (cond [(primitive-info? ftype) (let ([ptype (primitive-info-type ftype)] [read (primitive-info-reader ftype)]) (updator msg (cond [(eq? type ptype) (read port)] [(and repeated? (eq? type 'sized) (not (eq? ptype 'sized))) (read-sized (cut read-file <> read) port)] [else (syntax-error 'deserialize "wire type does not match declared type" type)])))] [(enum-info? ftype) (let ([integer->enum (enum-info-integer->enum ftype)]) (updator msg (cond [(eq? type 'int*) (integer->enum (read-int* port))] [(and repeated? (eq? type 'sized)) (map integer->enum (read-sized (cut read-file <> read-int*) port))] [else (syntax-error 'deserialize "wire type does not match declared type" type)])))] [(rtd? ftype) (updator msg (cond [(eq? type 'sized) (read-sized (cut deserialize ftype <>) port)] [else (syntax-error 'deserialize "wire type does not match declared type" type)]))])))] [else (write-tag/type tag type unknown) (case type [(int*) (write-uint* (read-uint* port) unknown)] [(64bit) (copy-port (make-limited-input-port port 8 #f) unknown)] [(32bit) (copy-port (make-limited-input-port port 4 #f) unknown)] [(sized) (let ([size (read-uint* port)]) (write-uint* size unknown) (copy-port (make-limited-input-port port size #f) unknown))])]) (loop)))) (message-unknown-set! msg (get-output-string unknown)) (unless (zero? (hash-table-size required)) (syntax-error 'deserialize "missing required fields" (hash-table-keys required))) 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)))))))) (write-string (message-unknown msg) #f port) (unless (zero? (hash-table-size required)) (syntax-error 'serialize "missing required fields" (hash-table-keys required)))))) |
Added protobuf.meta.
> > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | ;; -*- 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" "extend/protobuf/bigint.scm" "google/protobuf/compiler/plugin.scm" "generator.scm" "tests/run.scm" "tests/abook.proto" "tests/abook.scm")) |
Added protobuf.scm.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | ;; -*- mode: Scheme; -*- ;; ;; This file is part of Protocol Buffers for CHICKEN ;; Copyright (c) 2013 by Thomas Chust. All rights reserved. ;; ;; Permission is hereby granted, free of charge, to any person ;; obtaining a copy of this software and associated documentation ;; files (the Software), to deal in the Software without restriction, ;; including without limitation the rights to use, copy, modify, ;; merge, publish, distribute, sublicense, and/or sell copies of the ;; Software, and to permit persons to whom the Software is furnished ;; to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. (require-library srfi-4 srfi-18 srfi-42 srfi-4-comprehensions srfi-69 srfi-99 ports extras numbers) (module protobuf-encoding (make-limited-input-port read-uint* write-uint* read-sint* write-sint* read-int* write-int* read-bool write-bool read-fixed* read-fixed32 read-fixed64 read-sfixed32 read-sfixed64 write-fixed* write-fixed32 write-fixed64 write-sfixed32 write-sfixed64 read-float* read-float read-double write-float* write-float write-double read-sized-bytes write-sized-bytes read-sized-string write-sized-string read-sized write-sized read-tag/type write-tag/type) (import scheme chicken srfi-4 (only srfi-18 raise) srfi-42 srfi-4-comprehensions ports extras numbers) (include "encoding.scm")) (module protobuf-reflection (type-info make-type-info type-info? type-info-name primitive-info make-primitive-info primitive-info? primitive-info-type primitive-info-reader primitive-info-writer enum-info make-enum-info enum-info? enum-info-integer->enum enum-info-enum->integer message-info make-message-info message-info? message-info-constructor message-info-fields message-info-required field-info make-field-info field-info? field-info-type field-info-repeated? field-info-packed? field-info-accessor field-info-mutator message message? message-extensions message-unknown message-unknown-set! prop:protobuf) (import scheme (except chicken define-record-type) srfi-69 srfi-99) (include "reflection.scm")) (module protobuf-syntax (int32 int64 uint32 uint64 uint* sint32 sint64 sint* fixed32 fixed64 sfixed32 sfixed64 bool float double bytes string define-enum-type define-message-type define-message-extension) (import (except scheme string) (except chicken define-record-type) srfi-69 srfi-99 protobuf-encoding protobuf-reflection) (include "syntax.scm")) (module protobuf (serialize deserialize) (import scheme (except chicken define-record-type) srfi-69 srfi-99 ports extras protobuf-encoding protobuf-reflection) (reexport (only protobuf-reflection message? message-extensions message-unknown)) (include "main.scm")) |
Added protobuf.setup.
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | ;; -*- mode: Scheme; -*- (compile -s -O2 -d1 "protobuf.scm" -J) (compile -s -O2 -d0 "protobuf-encoding.import.scm") (compile -s -O2 -d0 "protobuf-reflection.import.scm") (compile -s -O2 -d0 "protobuf-syntax.import.scm") (compile -s -O2 -d0 "protobuf.import.scm") (install-extension 'protobuf '("protobuf.so" "protobuf-encoding.import.so" "protobuf-reflection.import.so" "protobuf-syntax.import.so" "protobuf.import.so") '((version "1.0.0"))) (compile -O2 -d1 "protoc-gen-chicken.scm") (install-program 'protoc-gen-chicken '("protoc-gen-chicken") '((version "1.0.0"))) |
Added protoc-gen-chicken.scm.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | ;; -*- mode: Scheme; -*- ;; ;; This file is part of Protocol Buffers for CHICKEN ;; Copyright (c) 2013 by Thomas Chust. All rights reserved. ;; ;; Permission is hereby granted, free of charge, to any person ;; obtaining a copy of this software and associated documentation ;; files (the Software), to deal in the Software without restriction, ;; including without limitation the rights to use, copy, modify, ;; merge, publish, distribute, sublicense, and/or sell copies of the ;; Software, and to permit persons to whom the Software is furnished ;; to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. (require-library srfi-1 srfi-13 srfi-69 data-structures irregex files ports extras protobuf) (include "google/protobuf/descriptor.scm") (include "extend/protobuf/bigint.scm") (include "google/protobuf/compiler/plugin.scm") (module protobuf-generator (proto-file-register! proto-file-translate generate-chicken) (import scheme chicken srfi-1 srfi-13 srfi-69 data-structures irregex files ports extras google-protobuf extend-protobuf google-protobuf-compiler) (include "generator.scm")) (import protobuf google-protobuf-compiler protobuf-generator) (serialize (generate-chicken (deserialize code-generator-request))) |
Added reflection.scm.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | ;; -*- mode: Scheme; -*- ;; ;; This file is part of Protocol Buffers for CHICKEN ;; Copyright (c) 2013 by Thomas Chust. All rights reserved. ;; ;; Permission is hereby granted, free of charge, to any person ;; obtaining a copy of this software and associated documentation ;; files (the Software), to deal in the Software without restriction, ;; including without limitation the rights to use, copy, modify, ;; merge, publish, distribute, sublicense, and/or sell copies of the ;; Software, and to permit persons to whom the Software is furnished ;; to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. (define-record-type type-info #t #t name) (define-record-type (primitive-info type-info) #t #t type reader writer) (define-record-printer (primitive-info v port) (fprintf port "#<primitive-type: ~a>" (type-info-name v))) (define-record-type (enum-info type-info) #t #t integer->enum enum->integer) (define-record-printer (enum-info v port) (fprintf port "#<enum-type: ~a>" (type-info-name v))) (define-record-type (message-info type-info) #t #t constructor fields required) (define-record-type field-info #t #t (type field-info-type*) repeated? packed? accessor mutator) (define (field-info-type v) (force (field-info-type* v))) (define-record-printer (message-info v port) (fprintf port "#<message-type: ~a ~s>" (type-info-name v) (hash-table-keys (message-info-fields v)))) (define-record-type (message #:uid 'protobuf:message) #f #t extensions (unknown)) (define-record-property prop:protobuf) |
Added syntax.scm.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 | ;; -*- mode: Scheme; -*- ;; ;; This file is part of Protocol Buffers for CHICKEN ;; Copyright (c) 2013 by Thomas Chust. All rights reserved. ;; ;; Permission is hereby granted, free of charge, to any person ;; obtaining a copy of this software and associated documentation ;; files (the Software), to deal in the Software without restriction, ;; including without limitation the rights to use, copy, modify, ;; merge, publish, distribute, sublicense, and/or sell copies of the ;; Software, and to permit persons to whom the Software is furnished ;; to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. (define-syntax define-primitive-type (syntax-rules () [(define-primitive-type name type reader writer) (define name (make-primitive-info 'name 'type reader writer))])) (define-primitive-type int32 int* read-int* write-int*) (define-primitive-type int64 int* read-int* write-int*) (define-primitive-type uint32 int* read-uint* write-uint*) (define-primitive-type uint64 int* read-uint* write-uint*) (define (uint* max-size) (primitive-info 'uint* 'int* (cut read-uint* <> max-size) (cut write-uint* <> <> max-size))) (define-primitive-type sint32 int* read-sint* write-sint*) (define-primitive-type sint64 int* read-sint* write-sint*) (define (sint* max-size) (primitive-info 'sint* 'int* (cut read-sint* <> max-size) (cut write-sint* <> <> max-size))) (define-primitive-type fixed32 32bit read-fixed32 write-fixed32) (define-primitive-type fixed64 64bit read-fixed64 write-fixed64) (define-primitive-type sfixed32 32bit read-sfixed32 write-sfixed32) (define-primitive-type sfixed64 64bit read-sfixed64 write-sfixed64) (define-primitive-type bool int* read-bool write-bool) (define-primitive-type float 32bit read-float write-float) (define-primitive-type double 64bit read-double write-double) (define-primitive-type bytes sized read-sized-bytes write-sized-bytes) (define-primitive-type string sized read-sized-string write-sized-string) (define-syntax define-enum-type (syntax-rules () [(define-enum-type name (alt tag) ...) (define name (make-enum-info 'name (lambda (int) (case int [(tag) 'alt] ... [else (syntax-error 'name "unknown enumeration tag" int)])) (lambda (sym) (case sym [(alt) tag] ... [else (syntax-error 'name "unknown enumeration value" sym)]))))])) (define-syntax %message-field-label (syntax-rules (required optional repeated packed) ;; packed? -------\ ;; repeated? ----\ | ;; required? -\ | | ;; | | | ;; v v v [(%message-field-label required) (values #t #f #f)] [(%message-field-label optional) (values #f #f #f)] [(%message-field-label repeated) (values #f #t #f)] [(%message-field-label packed) (values #f #t #t)])) (define-syntax %message-field-default (syntax-rules () [(%message-field-default expr) (lambda _ expr)] [(%message-field-default) void])) (define-syntax %define-message-constructor+predicate (er-macro-transformer (lambda (stx rename compare) (cons* (rename 'define-values) (map string->symbol (list (conc "make-" (cadr stx)) (conc (cadr stx) "?"))) (cddr stx))))) (define-syntax %define-message-accessor+mutator (er-macro-transformer (lambda (stx rename compare) (cons* (rename 'define-values) (map string->symbol (list (conc (cadr stx) "-" (caddr stx)) (conc (cadr stx) "-" (caddr stx) "-set!"))) (cdddr stx))))) (define-syntax define-message-type (syntax-rules () [(define-message-type name (label type field tag . default) ...) (begin (define name (letrec ([name (make-rtd 'name '#((mutable field) ...) #:parent message #:property prop:protobuf (lambda _ descriptor))] [descriptor (void)]) (set! descriptor (make-message-info 'name (let ([constructor* (rtd-constructor name)]) (lambda (#!key [field ((%message-field-default . default))] ...) (constructor* (make-hash-table eqv? eqv?-hash) "" field ...))) (make-hash-table eqv? eqv?-hash) (make-hash-table eqv? eqv?-hash))) (let-values ([(required? repeated? packed?) (%message-field-label label)] [(accessor mutator) (values (let ([accessor* (rtd-accessor name 'field)]) (lambda (msg #!optional [v* (%message-field-default . default)]) (let ([v (accessor* msg)]) (if (eq? v (void)) (if (procedure? v*) (v*) v*) v)))) (rtd-mutator name 'field))]) (hash-table-set! (message-info-fields descriptor) tag (make-field-info (delay type) repeated? packed? (getter-with-setter accessor mutator) mutator)) (when required? (hash-table-set! (message-info-required descriptor) tag #t))) ... name)) (%define-message-constructor+predicate name (values (message-info-constructor (prop:protobuf #f name)) (rtd-predicate name))) (%define-message-accessor+mutator name field (let ([descriptor (hash-table-ref (message-info-fields (prop:protobuf #f name)) tag)]) (values (field-info-accessor descriptor) (field-info-mutator descriptor)))) ...)])) (define-syntax define-message-extension (syntax-rules () [(define-message-extension name (label type field tag . default) ...) (begin (let-values ([(descriptor) (prop:protobuf #f name)] [(required? repeated? packed?) (%message-field-label label)] [(accessor mutator) (values (lambda (msg #!optional [v* (%message-field-default . default)]) (hash-table-ref (message-extensions msg) tag v*)) (lambda (msg v) (hash-table-set! (message-extensions msg) tag v)))]) (hash-table-set! (message-info-fields descriptor) tag (make-field-info (delay type) repeated? packed? (getter-with-setter accessor mutator) mutator)) (when required? (hash-table-set! (message-info-required descriptor) tag #t))) ... (%define-message-accessor+mutator name field (let ([descriptor (hash-table-ref (message-info-fields (prop:protobuf #f name)) tag)]) (values (field-info-accessor descriptor) (field-info-mutator descriptor)))) ...)])) |
Added tests/abook.proto.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | // This file is part of Protocol Buffers for CHICKEN // Copyright (c) 2013 by Thomas Chust. All rights reserved. // // Permission is hereby granted, free of charge, to any person // obtaining a copy of this software and associated documentation // files (the Software), to deal in the Software without restriction, // including without limitation the rights to use, copy, modify, // merge, publish, distribute, sublicense, and/or sell copies of the // Software, and to permit persons to whom the Software is furnished // to do so, subject to the following conditions: // // The above copyright notice and this permission notice shall be // included in all copies or substantial portions of the Software. // // THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, // EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF // MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND // NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS // BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN // ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN // CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE // SOFTWARE. package abook; message Person { required string name = 1; required int32 id = 2; optional string email = 3; enum PhoneType { MOBILE = 0; HOME = 1; WORK = 2; } message PhoneNumber { required string number = 1; optional PhoneType type = 2 [default = HOME]; } repeated PhoneNumber phone = 4; } message AddressBook { repeated Person person = 1; } |
Added tests/abook.scm.
> > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | ;; Generated by protoc-gen-chicken v1.0.0 (module abook * (import (except scheme string) chicken protobuf-syntax) (define-enum-type person:phone-type (mobile 0) (home 1) (work 2)) (define-message-type person:phone-number (required string number 1) (optional person:phone-type type 2 'home)) (define-message-type person (required string name 1) (required int32 id 2) (optional string email 3) (repeated person:phone-number phone 4)) (define-message-type address-book (repeated person person 1))) |
Added tests/run.scm.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | ;; -*- mode: Scheme; -*- ;; ;; This file is part of Protocol Buffers for CHICKEN ;; Copyright (c) 2013 by Thomas Chust. All rights reserved. ;; ;; Permission is hereby granted, free of charge, to any person ;; obtaining a copy of this software and associated documentation ;; files (the Software), to deal in the Software without restriction, ;; including without limitation the rights to use, copy, modify, ;; merge, publish, distribute, sublicense, and/or sell copies of the ;; Software, and to permit persons to whom the Software is furnished ;; to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. (require-library srfi-78 srfi-99 protobuf) (include "abook.scm") (import srfi-78 srfi-99 protobuf protobuf-reflection abook) (define (message-rtd? v) (and (rtd? v) (message-info? (prop:protobuf #f v)))) (check (message-rtd? person) => #t) (check (enum-info? person:phone-type) => #t) (check (message-rtd? person:phone-number) => #t) (check (message-rtd? address-book) => #t) (check ((enum-info-integer->enum person:phone-type) 2) => 'work) (check ((enum-info-enum->integer person:phone-type) 'home) => 1) (define msg (make-address-book #:person (list (make-person #:id 42 #:name "Jane Doe" #:phone (list (make-person:phone-number #:number "+12-3456-7890"))) (make-person #:id 23 #:name "Johannes Mustermann" #:email "joe@example.com" #:phone (list (make-person:phone-number #:number "+67-876743724-8751751" #:type 'mobile) (make-person:phone-number #:number "+60-9848752576-987832" #:type 'work)))))) (define (check-structure msg) (check (message? msg) => #t) (check (address-book? msg) => #t) (let ([persons (address-book-person msg '())]) (check (length persons) => 2) (let ([jane (first persons)] [joe (second persons)]) (check (person? jane) => #t) (check (person-id jane) => 42) (check (person-name jane) => "Jane Doe") (check (person-email jane) => (void)) (check (person-email jane "jane@example.com") => "jane@example.com") (let ([phones (person-phone jane)]) (check (length phones) => 1) (let ([phone (car phones)]) (check (person:phone-number-number phone) => "+12-3456-7890") (check (person:phone-number-type phone) => 'home))) (check (person? joe) => #t) (check (person-id joe) => 23) (check (person-name joe) => "Johannes Mustermann") (check (person-email joe) => "joe@example.com") (check (person-email joe "whatever@example.com") => "joe@example.com") (let ([phones (person-phone joe)]) (check (length phones) => 2) (let ([phone (first phones)]) (check (person:phone-number-number phone) => "+67-876743724-8751751") (check (person:phone-number-type phone) => 'mobile)) (let ([phone (second phones)]) (check (person:phone-number-number phone) => "+60-9848752576-987832") (check (person:phone-number-type phone) => 'work)))))) (check-structure msg) (check-structure (call-with-input-string (call-with-output-string (cut serialize msg <>)) (cut deserialize address-book <>))) (set! (address-book-person msg) (cdr (address-book-person msg))) (check (person-id (car (address-book-person msg))) => 23) (check-report) (exit (if (check-passed? (+ 7 (* 2 21))) 0 1)) |