1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Confidential and proprietary information of ITA Software, Inc. ;;;
5 ;;; Copyright (c) 2012 ITA Software, Inc. All rights reserved. ;;;
7 ;;; Original author: Scott McKay ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package "PROTO-IMPL")
14 ;;; Protocol buffers wire format
18 (eval-when (:compile-toplevel :load-toplevel :execute)
20 (defconstant $wire-type-varint 0)
21 (defconstant $wire-type-64bit 1)
22 (defconstant $wire-type-string 2)
23 (defconstant $wire-type-start-group 3) ;supposedly obsolete
24 (defconstant $wire-type-end-group 4) ;supposedly obsolete
25 (defconstant $wire-type-32bit 5)
30 (defun make-tag (type index)
31 "Given a wire type or the name of a Protobufs type and a field index,
32 return the tag that encodes both of them."
33 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
34 (if (typep type 'fixnum)
35 (ilogior type (iash index 3))
36 (let ((type (ecase type
37 ((:int32 :uint32) $wire-type-varint)
38 ((:int64 :uint64) $wire-type-varint)
39 ((:sint32 :sint64) $wire-type-varint)
40 ((:fixed32 :sfixed32) $wire-type-32bit)
41 ((:fixed64 :sfixed64) $wire-type-64bit)
42 ((:string :bytes) $wire-type-string)
43 ((:bool) $wire-type-varint)
44 ((:float) $wire-type-32bit)
45 ((:double) $wire-type-64bit)
46 ;; A few of our homegrown types
47 ((:symbol) $wire-type-string)
48 ((:date :time :datetime :timestamp) $wire-type-64bit))))
49 (ilogior type (iash index 3))))))
51 (define-compiler-macro make-tag (&whole form type index)
52 (setq type (fold-symbol type))
53 (cond ((typep type 'fixnum)
54 `(ilogior ,type (iash ,index 3)))
56 (let ((type (ecase type
57 ((:int32 :uint32) $wire-type-varint)
58 ((:int64 :uint64) $wire-type-varint)
59 ((:sint32 :sint64) $wire-type-varint)
60 ((:fixed32 :sfixed32) $wire-type-32bit)
61 ((:fixed64 :sfixed64) $wire-type-64bit)
62 ((:string :bytes) $wire-type-string)
63 ((:bool) $wire-type-varint)
64 ((:float) $wire-type-32bit)
65 ((:double) $wire-type-64bit)
66 ;; A few of our homegrown types
67 ((:symbol) $wire-type-string)
68 ((:date :time :datetime :timestamp) $wire-type-64bit))))
69 `(ilogior ,type (iash ,index 3))))
72 (defun fold-symbol (x)
73 "Given an expression 'x', constant-fold it until it can be foleded no more."
76 (cond ((eq x last) (return x))
79 (constantp (second x)))
80 (shiftf last x (second x)))
83 (shiftf last x (symbol-value x)))
87 (defun zig-zag-encode32 (val)
88 (declare (optimize (speed 3) (safety 0) (debug 0)))
89 (declare (type (signed-byte 32) val))
90 (logxor (ash val 1) (ash val -31)))
92 (defun zig-zag-encode64 (val)
93 (declare (optimize (speed 3) (safety 0) (debug 0)))
94 (declare (type (signed-byte 64) val))
95 (logxor (ash val 1) (ash val -63)))
97 (define-compiler-macro zig-zag-encode32 (&whole form val)
99 `(locally (declare (optimize (speed 3) (safety 0) (debug 0))
100 (type (signed-byte 32) ,val))
101 (logxor (ash ,val 1) (ash ,val -31)))
104 (define-compiler-macro zig-zag-encode64 (&whole form val)
106 `(locally (declare (optimize (speed 3) (safety 0) (debug 0))
107 (type (signed-byte 64) ,val))
108 (logxor (ash ,val 1) (ash ,val -63)))
111 (defun zig-zag-decode32 (val)
112 (declare (optimize (speed 3) (safety 0) (debug 0)))
113 (logxor (ash val -1) (- (logand val 1))))
115 (defun zig-zag-decode64 (val)
116 (declare (optimize (speed 3) (safety 0) (debug 0)))
117 (logxor (ash val -1) (- (logand val 1))))
119 (define-compiler-macro zig-zag-decode32 (&whole form val)
121 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
122 (logxor (ash ,val -1) (- (logand ,val 1))))
125 (define-compiler-macro zig-zag-decode64 (&whole form val)
127 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
128 (logxor (ash ,val -1) (- (logand ,val 1))))
134 ;; Serialize 'val' of primitive type 'type' into the buffer
135 (defun serialize-prim (val type tag buffer index)
136 "Serializes a Protobufs primitive (scalar) value into the buffer at the given index.
137 The value is given by 'val', the primitive type by 'type'.
138 Modifies the buffer in place, and returns the new index into the buffer.
139 Watch out, this function turns off most type checking and all array bounds checking."
141 (type (unsigned-byte 32) tag)
143 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
144 (let ((idx (encode-uint32 tag buffer index)))
145 (declare (type fixnum idx))
148 (encode-uint32 (ldb (byte 32 0) val) buffer idx))
150 (encode-uint64 (ldb (byte 64 0) val) buffer idx))
152 (encode-uint32 (zig-zag-encode32 val) buffer idx))
154 (encode-uint64 (zig-zag-encode64 val) buffer idx))
156 (encode-fixed32 val buffer idx))
158 (encode-sfixed32 val buffer idx))
160 (encode-fixed64 val buffer idx))
162 (encode-sfixed64 val buffer idx))
164 (encode-string val buffer idx))
166 (encode-octets val buffer idx))
168 (encode-uint32 (if val 1 0) buffer idx))
170 (encode-single val buffer idx))
172 (encode-double val buffer idx))
173 ;; A few of our homegrown types
175 (let ((val (if (keywordp val)
177 ;; Non-keyword symbols are consy, avoid them if possible
178 (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val)))))
179 (encode-string val buffer idx)))
180 ((:date :time :datetime :timestamp)
181 (encode-uint64 (ldb (byte 64 0) val) buffer idx))))))
183 (define-compiler-macro serialize-prim (&whole form val type tag buffer index)
184 (setq type (fold-symbol type)
185 tag (fold-symbol tag))
186 (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
187 :fixed32 :sfixed32 :fixed64 :sfixed64
188 :string :bytes :bool :float :double))
189 `(locally (declare (optimize (speed 3) (safety 0) (debug 0))
190 (type (simple-array (unsigned-byte 8)) ,buffer)
191 ;; 'tag' is a constant, no need to declare its type
192 (type fixnum ,index))
193 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
194 (declare (type fixnum idx))
197 `(encode-uint32 (ldb (byte 32 0) ,val) ,buffer idx))
199 `(encode-uint64 (ldb (byte 64 0) ,val) ,buffer idx))
201 `(encode-uint32 ,val ,buffer idx))
203 `(encode-uint64 ,val ,buffer idx))
205 `(encode-uint32 (zig-zag-encode32 ,val) ,buffer idx))
207 `(encode-uint64 (zig-zag-encode64 ,val) ,buffer idx))
209 `(encode-fixed32 ,val ,buffer idx))
211 `(encode-sfixed32 ,val ,buffer idx))
213 `(encode-fixed64 ,val ,buffer idx))
215 `(encode-sfixed64 ,val ,buffer idx))
217 `(encode-string ,val ,buffer idx))
219 `(encode-octets ,val ,buffer idx))
221 `(encode-uint32 (if ,val 1 0) ,buffer idx))
223 `(encode-single ,val ,buffer idx))
225 `(encode-double ,val ,buffer idx)))))
228 (defun serialize-packed (values type tag buffer index)
229 "Serializes a set of packed values into the buffer at the given index.
230 The values are given by 'values', the primitive type by 'type'.
231 Modifies the buffer in place, and returns the new index into the buffer.
232 Watch out, this function turns off most type checking and all array bounds checking."
233 (declare (type (simple-array (unsigned-byte 8)) buffer)
234 (type (unsigned-byte 32) tag)
236 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
237 (let ((idx (encode-uint32 tag buffer index)))
238 (declare (type fixnum idx))
239 (multiple-value-bind (full-len len)
240 (packed-size values type tag)
241 (declare (type fixnum len) (ignore full-len))
242 (setq idx (encode-uint32 len buffer idx)))
245 (map () #'(lambda (val) (setq idx (encode-uint32 (ldb (byte 32 0) val) buffer idx))) values))
247 (map () #'(lambda (val) (setq idx (encode-uint64 (ldb (byte 64 0) val) buffer idx))) values))
249 (map () #'(lambda (val) (setq idx (encode-uint32 (zig-zag-encode32 val) buffer idx))) values))
251 (map () #'(lambda (val) (setq idx (encode-uint64 (zig-zag-encode64 val) buffer idx))) values))
253 (map () #'(lambda (val) (setq idx (encode-fixed32 val buffer idx))) values))
255 (map () #'(lambda (val) (setq idx (encode-sfixed32 val buffer idx))) values))
257 (map () #'(lambda (val) (setq idx (encode-fixed64 val buffer idx))) values))
259 (map () #'(lambda (val) (setq idx (encode-sfixed64 val buffer idx))) values))
261 (map () #'(lambda (val) (setq idx (encode-uint32 (if val 1 0) buffer idx))) values))
263 (map () #'(lambda (val) (setq idx (encode-single val buffer idx))) values))
265 (map () #'(lambda (val) (setq idx (encode-double val buffer idx))) values)))
268 (define-compiler-macro serialize-packed (&whole form values type tag buffer index)
269 (setq type (fold-symbol type)
270 tag (fold-symbol tag))
271 (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
272 :fixed32 :sfixed32 :fixed64 :sfixed64
273 :bool :float :double))
274 `(locally (declare (optimize (speed 3) (safety 0) (debug 0))
275 (type (simple-array (unsigned-byte 8)) ,buffer)
276 ;; 'tag' is a constant, no need to declare its type
277 (type fixnum ,index))
278 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
279 (declare (type fixnum idx))
280 (multiple-value-bind (full-len len)
281 (packed-size ,values ,type ,tag)
282 (declare (type fixnum len) (ignore full-len))
283 (setq idx (encode-uint32 len ,buffer idx)))
284 (map () #'(lambda (val)
287 `(setq idx (encode-uint32 (ldb (byte 32 0) val) ,buffer idx)))
289 `(setq idx (encode-uint64 (ldb (byte 64 0) val) ,buffer idx)))
291 `(setq idx (encode-uint32 val ,buffer idx)))
293 `(setq idx (encode-uint64 val ,buffer idx)))
295 `(setq idx (encode-uint32 (zig-zag-encode32 val) ,buffer idx)))
297 `(setq idx (encode-uint64 (zig-zag-encode64 val) ,buffer idx)))
299 `(setq idx (encode-fixed32 val ,buffer idx)))
301 `(setq idx (encode-sfixed32 val ,buffer idx)))
303 `(setq idx (encode-fixed64 val ,buffer idx)))
305 `(setq idx (encode-sfixed64 val ,buffer idx)))
307 `(setq idx (encode-uint32 (if val 1 0) ,buffer idx)))
309 `(setq idx (encode-single val ,buffer idx)))
311 `(setq idx (encode-double val ,buffer idx))))) ,values)
315 (defun serialize-enum (val enum-values tag buffer index)
316 "Serializes a Protobufs enum value into the buffer at the given index.
317 The value is given by 'val', the enum values are in 'enum-values'.
318 Modifies the buffer in place, and returns the new index into the buffer.
319 Watch out, this function turns off most type checking and all array bounds checking."
320 (declare (type (simple-array (unsigned-byte 8)) buffer)
321 (type (unsigned-byte 32) tag)
323 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
324 (let* ((val (let ((e (find val enum-values :key #'proto-value)))
325 (and e (proto-index e))))
326 (idx (encode-uint32 tag buffer index)))
327 (declare (type (unsigned-byte 32) val)
329 (encode-uint32 (ldb (byte 32 0) val) buffer idx))))
331 (defun serialize-packed-enum (values enum-values tag buffer index)
332 "Serializes Protobufs enum values into the buffer at the given index.
333 The values are given by 'values', the enum values are in 'enum-values'.
334 Modifies the buffer in place, and returns the new index into the buffer.
335 Watch out, this function turns off most type checking and all array bounds checking."
336 (declare (type (simple-array (unsigned-byte 8)) buffer)
337 (type (unsigned-byte 32) tag)
339 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
340 (let ((idx (encode-uint32 tag buffer index)))
341 (declare (type fixnum idx))
342 (multiple-value-bind (full-len len)
343 (packed-enum-size values enum-values tag)
344 (declare (type fixnum len) (ignore full-len))
345 (setq idx (encode-uint32 len buffer idx)))
346 (map () #'(lambda (val)
347 (let ((val (let ((e (find val enum-values :key #'proto-value)))
348 (and e (proto-index e)))))
349 (declare (type (unsigned-byte 32) val))
350 (setq idx (encode-uint32 (ldb (byte 32 0) val) buffer idx)))) values)
356 ;; Deserialize the next object of type 'type'
357 (defun deserialize-prim (type buffer index)
358 "Deserializes the next object of primitive type 'type'.
359 Deserializes from the byte vector 'buffer' starting at 'index'.
360 Returns the value and and the new index into the buffer.
361 Watch out, this function turns off most type checking and all array bounds checking."
362 (declare (type (simple-array (unsigned-byte 8)) buffer)
364 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
367 (decode-int32 buffer index))
369 (decode-int64 buffer index))
371 (decode-uint32 buffer index))
373 (decode-uint64 buffer index))
375 (multiple-value-bind (val idx)
376 (decode-uint32 buffer index)
377 (values (zig-zag-decode32 val) idx)))
379 (multiple-value-bind (val idx)
380 (decode-uint64 buffer index)
381 (values (zig-zag-decode64 val) idx)))
383 (decode-fixed32 buffer index))
385 (decode-sfixed32 buffer index))
387 (decode-fixed64 buffer index))
389 (decode-sfixed64 buffer index))
391 (decode-string buffer index))
393 (decode-octets buffer index))
395 (multiple-value-bind (val idx)
396 (decode-uint32 buffer index)
397 (values (if (i= val 0) nil t) idx)))
399 (decode-single buffer index))
401 (decode-double buffer index))
402 ;; A few of our homegrown types
404 ;; Note that this is consy, avoid it if possible
405 (multiple-value-bind (val idx)
406 (decode-string buffer index)
407 (values (make-lisp-symbol val) idx)))
408 ((:date :time :datetime :timestamp)
409 (decode-uint64 buffer index)))))
411 (define-compiler-macro deserialize-prim (&whole form type buffer index)
412 (setq type (fold-symbol type))
413 (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
414 :fixed32 :sfixed32 :fixed64 :sfixed64
415 :string :bytes :bool :float :double))
416 `(locally (declare (optimize (speed 3) (safety 0) (debug 0))
417 (type (simple-array (unsigned-byte 8)) ,buffer)
418 (type fixnum ,index))
421 `(decode-int32 ,buffer ,index))
423 `(decode-int64 ,buffer ,index))
425 `(decode-uint32 ,buffer ,index))
427 `(decode-uint64 ,buffer ,index))
429 `(multiple-value-bind (val idx)
430 (decode-uint32 ,buffer ,index)
431 (values (zig-zag-decode32 val) idx)))
433 `(multiple-value-bind (val idx)
434 (decode-uint64 ,buffer ,index)
435 (values (zig-zag-decode64 val) idx)))
437 `(decode-fixed32 ,buffer ,index))
439 `(decode-sfixed32 ,buffer ,index))
441 `(decode-fixed64 ,buffer ,index))
443 `(decode-sfixed64 ,buffer ,index))
445 `(decode-string ,buffer ,index))
447 `(decode-octets ,buffer ,index))
449 `(multiple-value-bind (val idx)
450 (decode-uint32 ,buffer ,index)
451 (values (if (i= val 0) nil t) idx)))
453 `(decode-single ,buffer ,index))
455 `(decode-double ,buffer ,index))))
458 (defun deserialize-packed (type buffer index)
459 "Deserializes the next packed values of type 'type'.
460 Deserializes from the byte vector 'buffer' starting at 'index'.
461 Returns the value and and the new index into the buffer.
462 Watch out, this function turns off most type checking and all array bounds checking."
463 (declare (type (simple-array (unsigned-byte 8)) buffer)
465 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
466 (multiple-value-bind (len idx)
467 (decode-uint32 buffer index)
468 (declare (type (unsigned-byte 32) len)
470 (let ((end (i+ idx len)))
471 (declare (type (unsigned-byte 32) end))
472 (with-collectors ((values collect-value))
475 (return-from deserialize-packed (values values idx)))
476 (multiple-value-bind (val nidx)
479 (decode-int32 buffer idx))
481 (decode-int64 buffer idx))
483 (decode-uint32 buffer idx))
485 (decode-uint64 buffer idx))
487 (multiple-value-bind (val nidx)
488 (decode-uint32 buffer idx)
489 (values (zig-zag-decode32 val) nidx)))
491 (multiple-value-bind (val nidx)
492 (decode-uint64 buffer idx)
493 (values (zig-zag-decode64 val) nidx)))
495 (decode-fixed32 buffer idx))
497 (decode-sfixed32 buffer idx))
499 (decode-fixed64 buffer idx))
501 (decode-sfixed64 buffer idx))
503 (multiple-value-bind (val nidx)
504 (decode-uint32 buffer idx)
505 (values (if (i= val 0) nil t) nidx)))
507 (decode-single buffer idx))
509 (decode-double buffer idx)))
511 (setq idx nidx))))))))
513 (define-compiler-macro deserialize-packed (&whole form type buffer index)
514 (setq type (fold-symbol type))
515 (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
516 :fixed32 :sfixed32 :fixed64 :sfixed64
517 :bool :float :double))
518 `(locally (declare (optimize (speed 3) (safety 0) (debug 0))
519 (type (simple-array (unsigned-byte 8)) ,buffer)
520 (type fixnum ,index))
521 (block deserialize-packed
522 (multiple-value-bind (len idx)
523 (decode-uint32 ,buffer ,index)
524 (declare (type (unsigned-byte 32) len)
526 (let ((end (i+ idx len)))
527 (declare (type (unsigned-byte 32) end))
528 (with-collectors ((values collect-value))
531 (return-from deserialize-packed (values values idx)))
532 (multiple-value-bind (val nidx)
535 `(decode-int32 ,buffer idx))
537 `(decode-int64 ,buffer idx))
539 `(decode-uint32 ,buffer idx))
541 `(decode-uint64 ,buffer idx))
543 `(multiple-value-bind (val nidx)
544 (decode-uint32 ,buffer idx)
545 (values (zig-zag-decode32 val) nidx)))
547 `(multiple-value-bind (val nidx)
548 (decode-uint64 ,buffer idx)
549 (values (zig-zag-decode64 val) nidx)))
551 `(decode-fixed32 ,buffer idx))
553 `(decode-sfixed32 ,buffer idx))
555 `(decode-fixed64 ,buffer idx))
557 `(decode-sfixed64 ,buffer idx))
559 `(multiple-value-bind (val nidx)
560 (decode-uint32 ,buffer idx)
561 (values (if (i= val 0) nil t) nidx)))
563 `(decode-single ,buffer idx))
565 `(decode-double ,buffer idx)))
567 (setq idx nidx))))))))
570 (defun deserialize-enum (enum-values buffer index)
571 "Deserializes the next enum value take from 'enum-values'.
572 Deserializes from the byte vector 'buffer' starting at 'index'.
573 Returns the value and and the new index into the buffer.
574 Watch out, this function turns off most type checking and all array bounds checking."
575 (declare (type (simple-array (unsigned-byte 8)) buffer)
577 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
578 (multiple-value-bind (val idx)
579 (decode-int32 buffer index)
580 (let ((val (let ((e (find val enum-values :key #'proto-index)))
581 (and e (proto-value e)))))
584 (defun deserialize-packed-enum (enum-values buffer index)
585 "Deserializes the next packed enum values given in 'enum-values'.
586 Deserializes from the byte vector 'buffer' starting at 'index'.
587 Returns the value and and the new index into the buffer.
588 Watch out, this function turns off most type checking and all array bounds checking."
589 (declare (type (simple-array (unsigned-byte 8)) buffer)
591 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
592 (multiple-value-bind (len idx)
593 (decode-uint32 buffer index)
594 (declare (type (unsigned-byte 32) len)
596 (let ((end (i+ idx len)))
597 (declare (type (unsigned-byte 32) end))
598 (with-collectors ((values collect-value))
601 (return-from deserialize-packed-enum (values values idx)))
602 (multiple-value-bind (val nidx)
603 (decode-int32 buffer idx)
604 (let ((val (let ((e (find val enum-values :key #'proto-index)))
605 (and e (proto-value e)))))
607 (setq idx nidx)))))))))
612 (defun prim-size (val type tag)
613 "Returns the size in bytes that the primitive object will take when serialized.
614 Watch out, this function turns off most type checking."
615 (declare (type (unsigned-byte 32) tag))
616 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
619 (i+ (length32 tag) (length32 (ldb (byte 32 0) val))))
621 (i+ (length32 tag) (length64 (ldb (byte 64 0) val))))
623 (i+ (length32 tag) (length32 (zig-zag-encode32 val))))
625 (i+ (length32 tag) (length64 (zig-zag-encode64 val))))
626 ((:fixed32 :sfixed32)
627 (i+ (length32 tag) 4))
628 ((:fixed64 :sfixed64)
629 (i+ (length32 tag) 8))
631 (let ((len (babel:string-size-in-octets val :encoding :utf-8)))
632 (i+ (length32 tag) (length32 len) len)))
634 (let ((len (length val)))
635 (i+ (length32 tag) (length32 len) len)))
637 (i+ (length32 tag) 1))
639 (i+ (length32 tag) 4))
641 (i+ (length32 tag) 8))
642 ;; A few of our homegrown types
644 (let ((len (if (keywordp val)
645 (length (symbol-name val))
646 (i+ (length (package-name (symbol-package val))) 1 (length (symbol-name val))))))
647 (i+ (length32 tag) (length32 len) len)))
648 ((:date :time :datetime :timestamp)
649 (i+ (length32 tag) 8)))))
651 (define-compiler-macro prim-size (&whole form val type tag)
652 (setq type (fold-symbol type)
653 tag (fold-symbol tag))
654 (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
655 :fixed32 :sfixed32 :fixed64 :sfixed64
656 :string :bytes :bool :float :double))
657 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
660 `(i+ (length32 ,tag) (length32 (ldb (byte 32 0) ,val))))
662 `(i+ (length32 ,tag) (length64 (ldb (byte 64 0) ,val))))
664 `(i+ (length32 ,tag) (length32 ,val)))
666 `(i+ (length32 ,tag) (length64 ,val)))
668 `(i+ (length32 ,tag) (length32 (zig-zag-encode32 ,val))))
670 `(i+ (length32 ,tag) (length64 (zig-zag-encode64 ,val))))
671 ((:fixed32 :sfixed32)
672 `(i+ (length32 ,tag) 4))
673 ((:fixed64 :sfixed64)
674 `(i+ (length32 ,tag) 8))
676 `(let ((len (babel:string-size-in-octets ,val :encoding :utf-8)))
677 (i+ (length32 ,tag) (length32 len) len)))
679 `(let ((len (length ,val)))
680 (i+ (length32 ,tag) (length32 len) len)))
682 `(i+ (length32 ,tag) 1))
684 `(i+ (length32 ,tag) 4))
686 `(i+ (length32 ,tag) 8))))
689 (defun packed-size (values type tag)
690 "Returns the size in bytes that the packed object will take when serialized.
691 Watch out, this function turns off most type checking."
692 (declare (type (unsigned-byte 32) tag))
693 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
694 (let ((len (let ((len 0))
695 (declare (type fixnum len))
696 (map () #'(lambda (val)
697 (iincf len (ecase type
698 ((:int32 :uint32) (length32 (ldb (byte 32 0) val)))
699 ((:int64 :uint64) (length64 (ldb (byte 64 0) val)))
700 ((:sint32) (length32 (zig-zag-encode32 val)))
701 ((:sint64) (length64 (zig-zag-encode64 val)))
702 ((:fixed32 :sfixed32) 4)
703 ((:fixed64 :sfixed64) 8)
706 ((:double) 8)))) values)
708 (declare (type (unsigned-byte 32) len))
709 ;; Two value: the full size of the packed object, and the size
710 ;; of just the payload
711 (values (i+ (length32 tag) (length32 len) len) len))))
713 (define-compiler-macro packed-size (&whole form values type tag)
714 (setq type (fold-symbol type)
715 tag (fold-symbol tag))
716 (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
717 :fixed32 :sfixed32 :fixed64 :sfixed64
718 :bool :float :double))
719 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
720 (let ((len (let ((len 0))
721 (declare (type fixnum len))
722 (map () #'(lambda (val)
723 (iincf len ,(ecase type
724 ((:int32) `(length32 (ldb (byte 32 0) val)))
725 ((:int64) `(length64 (ldb (byte 64 0) val)))
726 ((:uint32) `(length32 val))
727 ((:uint64) `(length64 val))
728 ((:sint32) `(length32 (zig-zag-encode32 val)))
729 ((:sint64) `(length64 (zig-zag-encode64 val)))
730 ((:fixed32 :sfixed32) `4)
731 ((:fixed64 :sfixed64) `8)
734 ((:double) `8)))) ,values)
736 (declare (type (unsigned-byte 32) len))
737 (values (i+ (length32 (the (unsigned-byte 32) ,tag)) (length32 len) len) len)))
740 (defun enum-size (val enum-values tag)
741 "Returns the size in bytes that the enum object will take when serialized."
742 (declare (type (unsigned-byte 32) tag))
743 (let ((idx (let ((e (find val enum-values :key #'proto-value)))
744 (and e (proto-index e)))))
745 (assert idx () "There is no enum value for ~S" val)
746 (i+ (length32 tag) (length32 (ldb (byte 32 0) idx)))))
748 (defun packed-enum-size (values enum-values tag)
749 "Returns the size in bytes that the enum values will take when serialized."
750 (let ((len (let ((len 0))
751 (declare (type fixnum len))
752 (map () #'(lambda (val)
753 (let ((idx (let ((e (find val enum-values :key #'proto-value)))
754 (and e (proto-index e)))))
755 (assert idx () "There is no enum value for ~S" val)
756 (iincf len (length32 (ldb (byte 32 0) val))))) values)
758 (declare (type (unsigned-byte 32) len))
759 ;; Two value: the full size of the packed object, and the size
760 ;; of just the payload
761 (values (i+ (length32 tag) (length32 len) len) len)))
764 ;;; Wire-level encoders
765 ;;; These are called at the lowest level, so arg types are assumed to be correct
767 (defun encode-uint32 (val buffer index)
768 "Encodes the unsigned 32-bit integer 'val' as a varint into the buffer
770 Modifies the buffer, and returns the new index into the buffer.
771 Watch out, this function turns off all type checking and array bounds checking."
772 (declare (optimize (speed 3) (safety 0) (debug 0)))
773 (declare (type (unsigned-byte 32) val)
774 (type (simple-array (unsigned-byte 8)) buffer)
776 ;; Seven bits at a time, least significant bits first
777 (loop do (let ((bits (ildb (byte 7 0) val)))
778 (declare (type (unsigned-byte 8) bits))
779 (setq val (iash val -7))
780 (setf (aref buffer index) (ilogior bits (if (i= val 0) 0 128)))
783 (values index buffer)) ;return the buffer to improve 'trace'
785 (defun encode-uint64 (val buffer index)
786 "Encodes the unsigned 64-bit integer 'val' as a varint into the buffer
788 Modifies the buffer, and returns the new index into the buffer.
789 Watch out, this function turns off all type checking and array bounds checking."
790 (declare (optimize (speed 3) (safety 0) (debug 0)))
791 (declare (type (unsigned-byte 64) val)
792 (type (simple-array (unsigned-byte 8)) buffer)
794 (loop do (let ((bits (ldb (byte 7 0) val)))
795 (declare (type (unsigned-byte 8) bits))
796 (setq val (ash val -7))
797 (setf (aref buffer index) (ilogior bits (if (zerop val) 0 128)))
800 (values index buffer))
802 (defun encode-fixed32 (val buffer index)
803 "Encodes the unsigned 32-bit integer 'val' as a fixed int into the buffer
805 Modifies the buffer, and returns the new index into the buffer.
806 Watch out, this function turns off all type checking and array bounds checking."
807 (declare (optimize (speed 3) (safety 0) (debug 0)))
808 (declare (type (unsigned-byte 32) val)
809 (type (simple-array (unsigned-byte 8)) buffer)
812 (let ((byte (ildb (byte 8 0) val)))
813 (declare (type (unsigned-byte 8) byte))
814 (setq val (iash val -8))
815 (setf (aref buffer index) byte)
817 (values index buffer))
819 (defun encode-fixed64 (val buffer index)
820 "Encodes the unsigned 64-bit integer 'val' as a fixed int into the buffer
822 Modifies the buffer, and returns the new index into the buffer.
823 Watch out, this function turns off all type checking and array bounds checking."
824 (declare (optimize (speed 3) (safety 0) (debug 0)))
825 (declare (type (unsigned-byte 64) val)
826 (type (simple-array (unsigned-byte 8)) buffer)
829 (let ((byte (ldb (byte 8 0) val)))
830 (declare (type (unsigned-byte 8) byte))
831 (setq val (ash val -8))
832 (setf (aref buffer index) byte)
834 (values index buffer))
836 (defun encode-sfixed32 (val buffer index)
837 "Encodes the signed 32-bit integer 'val' as a fixed int into the buffer
839 Modifies the buffer, and returns the new index into the buffer.
840 Watch out, this function turns off all type checking and array bounds checking."
841 (declare (optimize (speed 3) (safety 0) (debug 0)))
842 (declare (type (signed-byte 32) val)
843 (type (simple-array (unsigned-byte 8)) buffer)
846 (let ((byte (ildb (byte 8 0) val)))
847 (declare (type (unsigned-byte 8) byte))
848 (setq val (iash val -8))
849 (setf (aref buffer index) byte)
851 (values index buffer))
853 (defun encode-sfixed64 (val buffer index)
854 "Encodes the signed 64-bit integer 'val' as a fixed int into the buffer
856 Modifies the buffer, and returns the new index into the buffer.
857 Watch out, this function turns off all type checking and array bounds checking."
858 (declare (optimize (speed 3) (safety 0) (debug 0)))
859 (declare (type (signed-byte 64) val)
860 (type (simple-array (unsigned-byte 8)) buffer)
863 (let ((byte (ldb (byte 8 0) val)))
864 (declare (type (unsigned-byte 8) byte))
865 (setq val (ash val -8))
866 (setf (aref buffer index) byte)
868 (values index buffer))
870 (defun encode-single (val buffer index)
871 "Encodes the single float 'val' into the buffer at the given index.
872 Modifies the buffer, and returns the new index into the buffer.
873 Watch out, this function turns off all type checking and array bounds checking."
874 (declare (optimize (speed 3) (safety 0) (debug 0)))
875 (declare (type single-float val)
876 (type (simple-array (unsigned-byte 8)) buffer)
878 (let ((bits (single-float-bits val)))
880 (let ((byte (ldb (byte 8 0) bits)))
881 (declare (type (unsigned-byte 8) byte))
882 (setq bits (ash bits -8))
883 (setf (aref buffer index) byte)
885 (values index buffer))
887 (defun encode-double (val buffer index)
888 "Encodes the double float 'val' into the buffer at the given index.
889 Modifies the buffer, and returns the new index into the buffer.
890 Watch out, this function turns off all type checking and array bounds checking."
891 (declare (optimize (speed 3) (safety 0) (debug 0)))
892 (declare (type double-float val)
893 (type (simple-array (unsigned-byte 8)) buffer)
895 (multiple-value-bind (low high)
896 (double-float-bits val)
898 (let ((byte (ldb (byte 8 0) low)))
899 (declare (type (unsigned-byte 8) byte))
900 (setq low (ash low -8))
901 (setf (aref buffer index) byte)
904 (let ((byte (ldb (byte 8 0) high)))
905 (declare (type (unsigned-byte 8) byte))
906 (setq high (ash high -8))
907 (setf (aref buffer index) byte)
909 (values index buffer))
911 (defun encode-string (string buffer index)
912 "Encodes the octets into the buffer at the given index.
913 Modifies the buffer, and returns the new index into the buffer.
914 Watch out, this function turns off all type checking and array bounds checking."
915 (declare (optimize (speed 3) (safety 0) (debug 0)))
916 (declare (type (simple-array (unsigned-byte 8)) buffer)
918 (let* ((octets (babel:string-to-octets string :encoding :utf-8))
919 (len (length octets))
920 (idx (encode-uint32 len buffer index)))
921 (declare (type fixnum len)
922 (type (unsigned-byte 32) idx))
923 (replace buffer octets :start1 idx)
924 (values (i+ idx len) buffer)))
926 (defun encode-octets (octets buffer index)
927 "Encodes the octets into the buffer at the given index.
928 Modifies the buffer, and returns the new index into the buffer.
929 Watch out, this function turns off all type checking and array bounds checking."
930 (declare (optimize (speed 3) (safety 0) (debug 0)))
931 (declare (type (simple-array (unsigned-byte 8)) buffer)
933 (let* ((len (length octets))
934 (idx (encode-uint32 len buffer index)))
935 (declare (type fixnum len)
936 (type (unsigned-byte 32) idx))
937 (replace buffer octets :start1 idx)
938 (values (i+ idx len) buffer)))
941 ;;; Wire-level decoders
942 ;;; These are called at the lowest level, so arg types are assumed to be correct
944 ;; Decode the value from the buffer at the given index,
945 ;; then return the value and new index into the buffer
946 (defun decode-uint32 (buffer index)
947 "Decodes the next 32-bit varint integer in the buffer at the given index.
948 Returns both the decoded value and the new index into the buffer.
949 Watch out, this function turns off all type checking and array bounds checking."
950 (declare (optimize (speed 3) (safety 0) (debug 0)))
951 (declare (type (simple-array (unsigned-byte 8)) buffer)
953 ;; Seven bits at a time, least significant bits first
955 (declare (type (unsigned-byte 32) val))
956 (loop for places fixnum upfrom 0 by 7
957 for byte fixnum = (prog1 (aref buffer index) (iincf index))
958 do (setq val (ilogior val (iash (ildb (byte 7 0) byte) places)))
961 (assert (< val #.(ash 1 32)) ()
962 "The value ~D is longer than 32 bits" val)
963 (return (values val index))))))
965 (defun decode-uint64 (buffer index)
966 "Decodes the next 64-bit varint integer in the buffer at the given index.
967 Returns both the decoded value and the new index into the buffer.
968 Watch out, this function turns off all type checking and array bounds checking."
969 (declare (optimize (speed 3) (safety 0) (debug 0)))
970 (declare (type (simple-array (unsigned-byte 8)) buffer)
972 ;; Seven bits at a time, least significant bits first
974 (declare (type (unsigned-byte 64) val))
975 (loop for places fixnum upfrom 0 by 7
976 for byte fixnum = (prog1 (aref buffer index) (iincf index))
977 do (setq val (logior val (ash (ildb (byte 7 0) byte) places)))
979 finally (return (values val index)))))
981 (defun decode-int32 (buffer index)
982 "Decodes the next 32-bit varint integer in the buffer at the given index.
983 Returns both the decoded value and the new index into the buffer.
984 Watch out, this function turns off all type checking and array bounds checking."
985 (declare (optimize (speed 3) (safety 0) (debug 0)))
986 (declare (type (simple-array (unsigned-byte 8)) buffer)
988 (multiple-value-bind (val index)
989 (decode-uint32 buffer index)
990 (declare (type fixnum val))
991 (when (i= (ildb (byte 1 31) val) 1)
992 (idecf val #.(ash 1 32)))
995 (defun decode-int64 (buffer index)
996 "Decodes the next 64-bit varint integer in the buffer at the given index.
997 Returns both the decoded value and the new index into the buffer.
998 Watch out, this function turns off all type checking and array bounds checking."
999 (declare (optimize (speed 3) (safety 0) (debug 0)))
1000 (declare (type (simple-array (unsigned-byte 8)) buffer)
1001 (type fixnum index))
1002 (multiple-value-bind (val index)
1003 (decode-uint64 buffer index)
1004 (when (i= (ldb (byte 1 63 ) val) 1)
1005 (decf val #.(ash 1 64)))
1006 (values val index)))
1008 (defun decode-fixed32 (buffer index)
1009 "Decodes the next 32-bit unsigned fixed integer in the buffer at the given index.
1010 Returns both the decoded value and the new index into the buffer.
1011 Watch out, this function turns off all type checking and array bounds checking."
1012 (declare (optimize (speed 3) (safety 0) (debug 0)))
1013 (declare (type (simple-array (unsigned-byte 8)) buffer)
1014 (type fixnum index))
1015 ;; Eight bits at a time, least significant bits first
1017 (declare (type fixnum val))
1019 for places fixnum upfrom 0 by 8
1020 for byte fixnum = (prog1 (aref buffer index) (iincf index))
1021 do (setq val (ilogior val (iash byte places))))
1022 (values val index)))
1024 (defun decode-fixed64 (buffer index)
1025 "Decodes the next unsigned 64-bit fixed integer in the buffer at the given index.
1026 Returns both the decoded value and the new index into the buffer.
1027 Watch out, this function turns off all type checking and array bounds checking."
1028 (declare (optimize (speed 3) (safety 0) (debug 0)))
1029 (declare (type (simple-array (unsigned-byte 8)) buffer)
1030 (type fixnum index))
1031 ;; Eight bits at a time, least significant bits first
1034 for places fixnum upfrom 0 by 8
1035 for byte fixnum = (prog1 (aref buffer index) (iincf index))
1036 do (setq val (logior val (ash byte places))))
1037 (values val index)))
1039 (defun decode-sfixed32 (buffer index)
1040 "Decodes the next 32-bit signed fixed integer in the buffer at the given index.
1041 Returns both the decoded value and the new index into the buffer.
1042 Watch out, this function turns off all type checking and array bounds checking."
1043 (declare (optimize (speed 3) (safety 0) (debug 0)))
1044 (declare (type (simple-array (unsigned-byte 8)) buffer)
1045 (type fixnum index))
1046 ;; Eight bits at a time, least significant bits first
1048 (declare (type fixnum val))
1050 for places fixnum upfrom 0 by 8
1051 for byte fixnum = (prog1 (aref buffer index) (iincf index))
1052 do (setq val (ilogior val (iash byte places))))
1053 (when (i= (ldb (byte 1 31) val) 1) ;sign bit set, so negative value
1054 (decf val #.(ash 1 32)))
1055 (values val index)))
1057 (defun decode-sfixed64 (buffer index)
1058 "Decodes the next signed 64-bit fixed integer in the buffer at the given index.
1059 Returns both the decoded value and the new index into the buffer.
1060 Watch out, this function turns off all type checking and array bounds checking."
1061 (declare (optimize (speed 3) (safety 0) (debug 0)))
1062 (declare (type (simple-array (unsigned-byte 8)) buffer)
1063 (type fixnum index))
1064 ;; Eight bits at a time, least significant bits first
1067 for places fixnum upfrom 0 by 8
1068 for byte fixnum = (prog1 (aref buffer index) (iincf index))
1069 do (setq val (logior val (ash byte places))))
1070 (when (i= (ldb (byte 1 63) val) 1) ;sign bit set, so negative value
1071 (decf val #.(ash 1 64)))
1072 (values val index)))
1074 (defun decode-single (buffer index)
1075 "Decodes the next single float in the buffer at the given index.
1076 Returns both the decoded value and the new index into the buffer.
1077 Watch out, this function turns off all type checking and array bounds checking."
1078 (declare (optimize (speed 3) (safety 0) (debug 0)))
1079 (declare (type (simple-array (unsigned-byte 8)) buffer)
1080 (type fixnum index))
1081 ;; Eight bits at a time, least significant bits first
1084 for places fixnum upfrom 0 by 8
1085 for byte fixnum = (prog1 (aref buffer index) (iincf index))
1086 do (setq bits (logior bits (ash byte places))))
1087 (when (i= (ldb (byte 1 31) bits) 1) ;sign bit set, so negative value
1088 (decf bits #.(ash 1 32)))
1089 (values (make-single-float bits) index)))
1091 (defun decode-double (buffer index)
1092 "Decodes the next double float in the buffer at the given index.
1093 Returns both the decoded value and the new index into the buffer.
1094 Watch out, this function turns off all type checking and array bounds checking."
1095 (declare (optimize (speed 3) (safety 0) (debug 0)))
1096 (declare (type (simple-array (unsigned-byte 8)) buffer)
1097 (type fixnum index))
1098 ;; Eight bits at a time, least significant bits first
1102 for places fixnum upfrom 0 by 8
1103 for byte fixnum = (prog1 (aref buffer index) (iincf index))
1104 do (setq low (logior low (ash byte places))))
1106 for places fixnum upfrom 0 by 8
1107 for byte fixnum = (prog1 (aref buffer index) (iincf index))
1108 do (setq high (logior high (ash byte places))))
1109 ;; High bits are signed, but low bits are unsigned
1110 (when (i= (ldb (byte 1 31) high) 1) ;sign bit set, so negative value
1111 (decf high #.(ash 1 32)))
1112 (values (make-double-float low high) index)))
1114 (defun decode-string (buffer index)
1115 "Decodes the next UTF-8 encoded string in the buffer at the given index.
1116 Returns both the decoded string and the new index into the buffer.
1117 Watch out, this function turns off all type checking and array bounds checking."
1118 (declare (optimize (speed 3) (safety 0) (debug 0)))
1119 (declare (type (simple-array (unsigned-byte 8)) buffer)
1120 (type fixnum index))
1121 (multiple-value-bind (len idx)
1122 (decode-uint32 buffer index)
1123 (declare (type (unsigned-byte 32) len)
1125 (values (babel:octets-to-string buffer :start idx :end (i+ idx len) :encoding :utf-8) (i+ idx len))))
1127 (defun decode-octets (buffer index)
1128 "Decodes the next octets in the buffer at the given index.
1129 Returns both the decoded value and the new index into the buffer.
1130 Watch out, this function turns off all type checking and array bounds checking."
1131 (declare (optimize (speed 3) (safety 0) (debug 0)))
1132 (declare (type (simple-array (unsigned-byte 8)) buffer)
1133 (type fixnum index))
1134 (multiple-value-bind (len idx)
1135 (decode-uint32 buffer index)
1136 (declare (type (unsigned-byte 32) len)
1138 (values (subseq buffer idx (i+ idx len)) (i+ idx len))))
1141 ;;; Wire-level lengths
1142 ;;; These are called at the lowest level, so arg types are assumed to be correct
1144 (defun length32 (val)
1145 "Returns the length that 'val' will take when encoded as a 32-bit integer."
1146 (declare (optimize (speed 3) (safety 0) (debug 0)))
1147 (declare (type (unsigned-byte 32) val))
1149 (declare (type fixnum size))
1151 (setq val (iash val -7))
1156 (defun length64 (val)
1157 "Returns the length that 'val' will take when encoded as a 64-bit integer."
1158 (declare (optimize (speed 3) (safety 0) (debug 0)))
1159 (declare (type (unsigned-byte 64) val))
1161 (declare (type fixnum size))
1163 (setq val (ash val -7))
1169 ;;; Skipping elements
1170 ;;; This is called at the lowest level, so arg types are assumed to be correct
1172 (defun skip-element (buffer index tag)
1173 "Skip an element in the buffer at the index of the given wire type.
1174 Returns the new index in the buffer.
1175 Watch out, this function turns off all type checking and all array bounds checking."
1176 (declare (optimize (speed 3) (safety 0) (debug 0)))
1177 (declare (type (simple-array (unsigned-byte 8)) buffer)
1179 (type (unsigned-byte 32) tag))
1180 (case (ilogand tag #x7)
1181 ((#.$wire-type-varint)
1182 (loop for byte fixnum = (prog1 (aref buffer index) (iincf index))
1183 until (i< byte 128))
1185 ((#.$wire-type-string)
1186 (multiple-value-bind (len idx)
1187 (decode-uint32 buffer index)
1188 (declare (type (unsigned-byte 32) len)
1191 ((#.$wire-type-32bit)
1193 ((#.$wire-type-64bit)
1195 ((#.$wire-type-start-group)
1196 (loop (multiple-value-bind (new-tag idx)
1197 (decode-uint32 buffer index)
1198 (cond ((not (i= (ilogand new-tag #x7) $wire-type-end-group))
1199 ;; If it's not the end of a group, skip the next element
1200 (setq index (skip-element buffer idx new-tag)))
1201 ;; If it's the end of the expected group, we're done
1202 ((i= (i- tag $wire-type-start-group) (i- new-tag $wire-type-end-group))
1205 (assert (i= (i- tag $wire-type-start-group) (i- new-tag $wire-type-end-group)) ()
1206 "Couldn't find a matching end group tag"))))))