1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Free Software published under an MIT-like license. See LICENSE ;;;
5 ;;; Copyright (c) 2012 Google, 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 ;; If you need to debug the (de)serializer, (pushnew :debug-serialization *features*)
21 ;; Otherwise, we try to make (de)serialization as fast as possible,
22 ;; risking life and limb to do so
23 (defparameter $optimize-serialization
24 #+debug-serialization $optimize-default
25 #-debug-serialization $optimize-fast-unsafe)
27 (defconstant $wire-type-varint 0)
28 (defconstant $wire-type-64bit 1)
29 (defconstant $wire-type-string 2)
30 (defconstant $wire-type-start-group 3) ;supposedly deprecated, but no such luck
31 (defconstant $wire-type-end-group 4) ;supposedly deprecated
32 (defconstant $wire-type-32bit 5)
37 (defun make-tag (type index)
38 "Given a wire type or the name of a Protobufs type and a field index,
39 return the tag that encodes both of them."
40 (locally (declare #.$optimize-serialization)
41 (if (typep type 'fixnum)
42 (ilogior type (iash index 3))
43 (let ((type (ecase type
44 ((:int32 :uint32) $wire-type-varint)
45 ((:int64 :uint64) $wire-type-varint)
46 ((:sint32 :sint64) $wire-type-varint)
47 ((:fixed32 :sfixed32) $wire-type-32bit)
48 ((:fixed64 :sfixed64) $wire-type-64bit)
49 ((:string :bytes) $wire-type-string)
50 ((:bool) $wire-type-varint)
51 ((:float) $wire-type-32bit)
52 ((:double) $wire-type-64bit)
53 ;; A few of our homegrown types
54 ((:symbol) $wire-type-string)
55 ((:date :time :datetime :timestamp) $wire-type-64bit))))
56 (ilogior type (iash index 3))))))
58 (define-compiler-macro make-tag (&whole form type index)
59 (setq type (fold-symbol type))
60 (cond ((typep type 'fixnum)
61 `(ilogior ,type (iash ,index 3)))
63 (let ((type (ecase type
64 ((:int32 :uint32) $wire-type-varint)
65 ((:int64 :uint64) $wire-type-varint)
66 ((:sint32 :sint64) $wire-type-varint)
67 ((:fixed32 :sfixed32) $wire-type-32bit)
68 ((:fixed64 :sfixed64) $wire-type-64bit)
69 ((:string :bytes) $wire-type-string)
70 ((:bool) $wire-type-varint)
71 ((:float) $wire-type-32bit)
72 ((:double) $wire-type-64bit)
73 ;; A few of our homegrown types
74 ((:symbol) $wire-type-string)
75 ((:date :time :datetime :timestamp) $wire-type-64bit))))
76 `(ilogior ,type (iash ,index 3))))
79 (defun fold-symbol (x)
80 "Given an expression 'x', constant-fold it until it can be folded no more."
83 (cond ((eq x last) (return x))
86 (constantp (second x)))
87 (shiftf last x (second x)))
90 (shiftf last x (symbol-value x)))
94 (defmacro gen-zig-zag (bits)
95 "Generate 32- or 64-bit versions of zig-zag encoder/decoder."
96 (assert (and (plusp bits) (zerop (mod bits 8))))
97 (let* ((zig-zag-encode (fintern "~A~A" 'zig-zag-encode bits))
98 (zig-zag-decode (fintern "~A~A" 'zig-zag-decode bits))
99 (zig-zag-shift (1+ (- bits))))
101 (defun ,zig-zag-encode (val)
102 (declare #.$optimize-serialization)
103 (declare (type (signed-byte ,bits) val))
104 (logxor (ash val 1) (ash val ,zig-zag-shift)))
105 (define-compiler-macro ,zig-zag-encode (&whole form val)
107 `(locally (declare #.$optimize-serialization
108 (type (signed-byte ,',bits) ,val))
109 (logxor (ash ,val 1) (ash ,val ,',zig-zag-shift)))
111 (defun ,zig-zag-decode (val)
112 (declare #.$optimize-serialization)
113 (declare (type (unsigned-byte ,bits) val))
114 (logxor (ash val -1) (- (logand val 1))))
115 (define-compiler-macro ,zig-zag-decode (&whole form val)
117 `(locally (declare #.$optimize-serialization
118 (type (unsigned-byte ,',bits) ,val))
119 (logxor (ash ,val -1) (- (logand ,val 1))))
128 ;; Serialize 'val' of primitive type 'type' into the buffer
129 (defun serialize-prim (val type tag buffer index)
130 "Serializes a Protobufs primitive (scalar) value into the buffer at the given index.
131 The value is given by 'val', the primitive type by 'type'.
132 Modifies the buffer in place, and returns the new index into the buffer.
133 Watch out, this function turns off most type checking and all array bounds checking."
134 (declare (type (unsigned-byte 32) tag)
136 (locally (declare #.$optimize-serialization)
137 (let ((idx (encode-uint32 tag buffer index)))
138 (declare (type fixnum idx))
141 (encode-int val buffer idx))
143 (encode-uint32 val buffer idx))
145 (encode-uint64 val buffer idx))
147 (encode-uint32 (zig-zag-encode32 val) buffer idx))
149 (encode-uint64 (zig-zag-encode64 val) buffer idx))
151 (encode-fixed32 val buffer idx))
153 (encode-sfixed32 val buffer idx))
155 (encode-fixed64 val buffer idx))
157 (encode-sfixed64 val buffer idx))
159 (encode-string val buffer idx))
161 (encode-octets val buffer idx))
163 (encode-uint32 (if val 1 0) buffer idx))
165 (encode-single val buffer idx))
167 (encode-double val buffer idx))
168 ;; A few of our homegrown types
170 (let ((val (if (keywordp val)
172 ;; Non-keyword symbols are consy, avoid them if possible
173 (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val)))))
174 (encode-string val buffer idx)))
175 ((:date :time :datetime :timestamp)
176 (encode-uint64 val buffer idx))))))
178 (define-compiler-macro serialize-prim (&whole form val type tag buffer index)
179 (setq type (fold-symbol type)
180 tag (fold-symbol tag))
181 (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
182 :fixed32 :sfixed32 :fixed64 :sfixed64
183 :string :bytes :bool :float :double))
184 `(locally (declare #.$optimize-serialization
185 (type (simple-array (unsigned-byte 8)) ,buffer)
186 ;; 'tag' is a constant, no need to declare its type
187 (type fixnum ,index))
188 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
189 (declare (type fixnum idx))
192 `(encode-int ,val ,buffer idx))
194 `(encode-uint32 ,val ,buffer idx))
196 `(encode-uint64 ,val ,buffer idx))
198 `(encode-uint32 (zig-zag-encode32 ,val) ,buffer idx))
200 `(encode-uint64 (zig-zag-encode64 ,val) ,buffer idx))
202 `(encode-fixed32 ,val ,buffer idx))
204 `(encode-sfixed32 ,val ,buffer idx))
206 `(encode-fixed64 ,val ,buffer idx))
208 `(encode-sfixed64 ,val ,buffer idx))
210 `(encode-string ,val ,buffer idx))
212 `(encode-octets ,val ,buffer idx))
214 `(encode-uint32 (if ,val 1 0) ,buffer idx))
216 `(encode-single ,val ,buffer idx))
218 `(encode-double ,val ,buffer idx)))))
221 (defun serialize-packed (values type tag buffer index &optional vectorp)
222 "Serializes a set of packed values into the buffer at the given index.
223 The values are given by 'values', the primitive type by 'type'.
224 Modifies the buffer in place, and returns the new index into the buffer.
225 Watch out, this function turns off most type checking and all array bounds checking."
226 (declare (ignore vectorp)
227 (type (simple-array (unsigned-byte 8)) buffer)
228 (type (unsigned-byte 32) tag)
230 (locally (declare #.$optimize-serialization)
231 (let ((idx (encode-uint32 tag buffer index)))
232 (declare (type fixnum idx))
233 (multiple-value-bind (full-len len)
234 (packed-size values type tag)
235 (declare (type fixnum len) (ignore full-len))
236 (setq idx (encode-uint32 len buffer idx)))
239 (map () #'(lambda (val) (setq idx (encode-int val buffer idx))) values))
241 (map () #'(lambda (val) (setq idx (encode-uint32 val buffer idx))) values))
243 (map () #'(lambda (val) (setq idx (encode-uint64 val buffer idx))) values))
245 (map () #'(lambda (val) (setq idx (encode-uint32 (zig-zag-encode32 val) buffer idx))) values))
247 (map () #'(lambda (val) (setq idx (encode-uint64 (zig-zag-encode64 val) buffer idx))) values))
249 (map () #'(lambda (val) (setq idx (encode-fixed32 val buffer idx))) values))
251 (map () #'(lambda (val) (setq idx (encode-sfixed32 val buffer idx))) values))
253 (map () #'(lambda (val) (setq idx (encode-fixed64 val buffer idx))) values))
255 (map () #'(lambda (val) (setq idx (encode-sfixed64 val buffer idx))) values))
257 (map () #'(lambda (val) (setq idx (encode-uint32 (if val 1 0) buffer idx))) values))
259 (map () #'(lambda (val) (setq idx (encode-single val buffer idx))) values))
261 (map () #'(lambda (val) (setq idx (encode-double val buffer idx))) values)))
264 ;; The optimized serializers supply 'vectorp' so we can generate better code
265 (define-compiler-macro serialize-packed (&whole form values type tag buffer index
266 &optional (vectorp nil vectorp-p))
267 (setq type (fold-symbol type)
268 tag (fold-symbol tag))
270 `(member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
271 :fixed32 :sfixed32 :fixed64 :sfixed64
272 :bool :float :double)))
273 `(locally (declare #.$optimize-serialization
274 (type (simple-array (unsigned-byte 8)) ,buffer)
275 ;; 'tag' is a constant, no need to declare its type
276 (type fixnum ,index))
277 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
278 (declare (type fixnum idx))
279 (multiple-value-bind (full-len len)
280 (packed-size ,values ,type ,tag)
281 (declare (type fixnum len) (ignore full-len))
282 (setq idx (encode-uint32 len ,buffer idx)))
283 (,(if vectorp 'dovector 'dolist) (val ,values)
286 `(setq idx (encode-int val ,buffer idx)))
288 `(setq idx (encode-uint32 val ,buffer idx)))
290 `(setq idx (encode-uint64 val ,buffer idx)))
292 `(setq idx (encode-uint32 (zig-zag-encode32 val) ,buffer idx)))
294 `(setq idx (encode-uint64 (zig-zag-encode64 val) ,buffer idx)))
296 `(setq idx (encode-fixed32 val ,buffer idx)))
298 `(setq idx (encode-sfixed32 val ,buffer idx)))
300 `(setq idx (encode-fixed64 val ,buffer idx)))
302 `(setq idx (encode-sfixed64 val ,buffer idx)))
304 `(setq idx (encode-uint32 (if val 1 0) ,buffer idx)))
306 `(setq idx (encode-single val ,buffer idx)))
308 `(setq idx (encode-double val ,buffer idx)))))
312 (defun serialize-enum (val enum-values tag buffer index)
313 "Serializes a Protobufs enum value into the buffer at the given index.
314 The value is given by 'val', the enum values are in 'enum-values'.
315 Modifies the buffer in place, and returns the new index into the buffer.
316 Watch out, this function turns off most type checking and all array bounds checking."
317 (declare (type list enum-values)
318 (type (simple-array (unsigned-byte 8)) buffer)
319 (type (unsigned-byte 32) tag)
321 (locally (declare #.$optimize-serialization)
322 (let* ((val (let ((e (find val enum-values :key #'proto-value)))
323 (and e (proto-index e))))
324 (idx (encode-uint32 tag buffer index)))
325 (declare (type (unsigned-byte 32) val)
327 (encode-uint32 val buffer idx))))
329 (defun serialize-packed-enum (values enum-values tag buffer index)
330 "Serializes Protobufs enum values into the buffer at the given index.
331 The values are given by 'values', the enum values are in 'enum-values'.
332 Modifies the buffer in place, and returns the new index into the buffer.
333 Watch out, this function turns off most type checking and all array bounds checking."
334 (declare (type list enum-values)
335 (type (simple-array (unsigned-byte 8)) buffer)
336 (type (unsigned-byte 32) tag)
338 (locally (declare #.$optimize-serialization)
339 (let ((idx (encode-uint32 tag buffer index)))
340 (declare (type fixnum idx))
341 (multiple-value-bind (full-len len)
342 (packed-enum-size values enum-values tag)
343 (declare (type fixnum len) (ignore full-len))
344 (setq idx (encode-uint32 len buffer idx)))
345 (map () #'(lambda (val)
346 (let ((val (let ((e (find val enum-values :key #'proto-value)))
347 (and e (proto-index e)))))
348 (declare (type (unsigned-byte 32) val))
349 (setq idx (encode-uint32 val buffer idx)))) values)
355 ;; Deserialize the next object of type 'type'
356 (defun deserialize-prim (type buffer index)
357 "Deserializes the next object of primitive type 'type'.
358 Deserializes from the byte vector 'buffer' starting at 'index'.
359 Returns the value and and the new index into the buffer.
360 Watch out, this function turns off most type checking and all array bounds checking."
361 (declare (type (simple-array (unsigned-byte 8)) buffer)
363 (locally (declare #.$optimize-serialization)
366 (decode-int buffer index))
368 (decode-uint32 buffer index))
370 (decode-uint64 buffer index))
372 (multiple-value-bind (val idx)
373 (decode-uint32 buffer index)
374 (values (zig-zag-decode32 val) idx)))
376 (multiple-value-bind (val idx)
377 (decode-uint64 buffer index)
378 (values (zig-zag-decode64 val) idx)))
380 (decode-fixed32 buffer index))
382 (decode-sfixed32 buffer index))
384 (decode-fixed64 buffer index))
386 (decode-sfixed64 buffer index))
388 (decode-string buffer index))
390 (decode-octets buffer index))
392 (multiple-value-bind (val idx)
393 (decode-uint32 buffer index)
394 (values (if (i= val 0) nil t) idx)))
396 (decode-single buffer index))
398 (decode-double buffer index))
399 ;; A few of our homegrown types
401 ;; Note that this is consy, avoid it if possible
402 (multiple-value-bind (val idx)
403 (decode-string buffer index)
404 (values (make-lisp-symbol val) idx)))
405 ((:date :time :datetime :timestamp)
406 (decode-uint64 buffer index)))))
408 (define-compiler-macro deserialize-prim (&whole form type buffer index)
409 (setq type (fold-symbol type))
410 (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
411 :fixed32 :sfixed32 :fixed64 :sfixed64
412 :string :bytes :bool :float :double))
413 `(locally (declare #.$optimize-serialization
414 (type (simple-array (unsigned-byte 8)) ,buffer)
415 (type fixnum ,index))
418 `(decode-int ,buffer ,index))
420 `(decode-uint32 ,buffer ,index))
422 `(decode-uint64 ,buffer ,index))
424 `(multiple-value-bind (val idx)
425 (decode-uint32 ,buffer ,index)
426 (values (zig-zag-decode32 val) idx)))
428 `(multiple-value-bind (val idx)
429 (decode-uint64 ,buffer ,index)
430 (values (zig-zag-decode64 val) idx)))
432 `(decode-fixed32 ,buffer ,index))
434 `(decode-sfixed32 ,buffer ,index))
436 `(decode-fixed64 ,buffer ,index))
438 `(decode-sfixed64 ,buffer ,index))
440 `(decode-string ,buffer ,index))
442 `(decode-octets ,buffer ,index))
444 `(multiple-value-bind (val idx)
445 (decode-uint32 ,buffer ,index)
446 (values (if (i= val 0) nil t) idx)))
448 `(decode-single ,buffer ,index))
450 `(decode-double ,buffer ,index))))
453 (defun deserialize-packed (type buffer index)
454 "Deserializes the next packed values of type 'type'.
455 Deserializes from the byte vector 'buffer' starting at 'index'.
456 Returns the value and and the new index into the buffer.
457 Watch out, this function turns off most type checking and all array bounds checking."
458 (declare (type (simple-array (unsigned-byte 8)) buffer)
460 (locally (declare #.$optimize-serialization)
461 (multiple-value-bind (len idx)
462 (decode-uint32 buffer index)
463 (declare (type (unsigned-byte 32) len)
465 (let ((end (i+ idx len)))
466 (declare (type (unsigned-byte 32) end))
467 (with-collectors ((values collect-value))
470 (return-from deserialize-packed (values values idx)))
471 (multiple-value-bind (val nidx)
474 (decode-int buffer idx))
476 (decode-uint32 buffer idx))
478 (decode-uint64 buffer idx))
480 (multiple-value-bind (val nidx)
481 (decode-uint32 buffer idx)
482 (values (zig-zag-decode32 val) nidx)))
484 (multiple-value-bind (val nidx)
485 (decode-uint64 buffer idx)
486 (values (zig-zag-decode64 val) nidx)))
488 (decode-fixed32 buffer idx))
490 (decode-sfixed32 buffer idx))
492 (decode-fixed64 buffer idx))
494 (decode-sfixed64 buffer idx))
496 (multiple-value-bind (val nidx)
497 (decode-uint32 buffer idx)
498 (values (if (i= val 0) nil t) nidx)))
500 (decode-single buffer idx))
502 (decode-double buffer idx)))
504 (setq idx nidx))))))))
506 (define-compiler-macro deserialize-packed (&whole form type buffer index)
507 (setq type (fold-symbol type))
508 (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
509 :fixed32 :sfixed32 :fixed64 :sfixed64
510 :bool :float :double))
511 `(locally (declare #.$optimize-serialization
512 (type (simple-array (unsigned-byte 8)) ,buffer)
513 (type fixnum ,index))
514 (block deserialize-packed
515 (multiple-value-bind (len idx)
516 (decode-uint32 ,buffer ,index)
517 (declare (type (unsigned-byte 32) len)
519 (let ((end (i+ idx len)))
520 (declare (type (unsigned-byte 32) end))
521 (with-collectors ((values collect-value))
524 (return-from deserialize-packed (values values idx)))
525 (multiple-value-bind (val nidx)
528 `(decode-int ,buffer idx))
530 `(decode-uint32 ,buffer idx))
532 `(decode-uint64 ,buffer idx))
534 `(multiple-value-bind (val nidx)
535 (decode-uint32 ,buffer idx)
536 (values (zig-zag-decode32 val) nidx)))
538 `(multiple-value-bind (val nidx)
539 (decode-uint64 ,buffer idx)
540 (values (zig-zag-decode64 val) nidx)))
542 `(decode-fixed32 ,buffer idx))
544 `(decode-sfixed32 ,buffer idx))
546 `(decode-fixed64 ,buffer idx))
548 `(decode-sfixed64 ,buffer idx))
550 `(multiple-value-bind (val nidx)
551 (decode-uint32 ,buffer idx)
552 (values (if (i= val 0) nil t) nidx)))
554 `(decode-single ,buffer idx))
556 `(decode-double ,buffer idx)))
558 (setq idx nidx))))))))
561 (defun deserialize-enum (enum-values buffer index)
562 "Deserializes the next enum value take from 'enum-values'.
563 Deserializes from the byte vector 'buffer' starting at 'index'.
564 Returns the value and and the new index into the buffer.
565 Watch out, this function turns off most type checking and all array bounds checking."
566 (declare (type list enum-values)
567 (type (simple-array (unsigned-byte 8)) buffer)
569 (locally (declare #.$optimize-serialization)
570 (multiple-value-bind (val idx)
571 (decode-int buffer index)
572 (let ((val (let ((e (find val enum-values :key #'proto-index)))
573 (and e (proto-value e)))))
576 (defun deserialize-packed-enum (enum-values buffer index)
577 "Deserializes the next packed enum values given in 'enum-values'.
578 Deserializes from the byte vector 'buffer' starting at 'index'.
579 Returns the value and and the new index into the buffer.
580 Watch out, this function turns off most type checking and all array bounds checking."
581 (declare (type list enum-values)
582 (type (simple-array (unsigned-byte 8)) buffer)
584 (locally (declare #.$optimize-serialization)
585 (multiple-value-bind (len idx)
586 (decode-uint32 buffer index)
587 (declare (type (unsigned-byte 32) len)
589 (let ((end (i+ idx len)))
590 (declare (type (unsigned-byte 32) end))
591 (with-collectors ((values collect-value))
594 (return-from deserialize-packed-enum (values values idx)))
595 (multiple-value-bind (val nidx)
596 (decode-int buffer idx)
597 (let ((val (let ((e (find val enum-values :key #'proto-index)))
598 (and e (proto-value e)))))
600 (setq idx nidx)))))))))
605 (defun prim-size (val type tag)
606 "Returns the size in bytes that the primitive object will take when serialized.
607 Watch out, this function turns off most type checking."
608 (declare (type (unsigned-byte 32) tag))
609 (locally (declare #.$optimize-serialization)
611 ((:int32 :uint32 :int64 :uint64)
612 (i+ (varint-length tag) (varint-length val)))
614 (i+ (varint-length tag) (varint-length (zig-zag-encode32 val))))
616 (i+ (varint-length tag) (varint-length (zig-zag-encode64 val))))
617 ((:fixed32 :sfixed32)
618 (i+ (varint-length tag) 4))
619 ((:fixed64 :sfixed64)
620 (i+ (varint-length tag) 8))
622 (let ((len (babel:string-size-in-octets val :encoding :utf-8)))
623 (i+ (varint-length tag) (varint-length len) len)))
625 (let ((len (length val)))
626 (i+ (varint-length tag) (varint-length len) len)))
628 (i+ (varint-length tag) 1))
630 (i+ (varint-length tag) 4))
632 (i+ (varint-length tag) 8))
633 ;; A few of our homegrown types
635 (let ((len (if (keywordp val)
636 (length (symbol-name val))
637 (i+ (length (package-name (symbol-package val))) 1 (length (symbol-name val))))))
638 (i+ (varint-length tag) (varint-length len) len)))
639 ((:date :time :datetime :timestamp)
640 (i+ (varint-length tag) 8)))))
642 (define-compiler-macro prim-size (&whole form val type tag)
643 (setq type (fold-symbol type)
644 tag (fold-symbol tag))
645 (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
646 :fixed32 :sfixed32 :fixed64 :sfixed64
647 :string :bytes :bool :float :double))
648 `(locally (declare #.$optimize-serialization)
650 ((:int32 :int64 :uint32 :uint64)
651 `(i+ (varint-length ,tag) (varint-length ,val)))
653 `(i+ (varint-length ,tag) (varint-length (zig-zag-encode32 ,val))))
655 `(i+ (varint-length ,tag) (varint-length (zig-zag-encode64 ,val))))
656 ((:fixed32 :sfixed32)
657 `(i+ (varint-length ,tag) 4))
658 ((:fixed64 :sfixed64)
659 `(i+ (varint-length ,tag) 8))
661 `(let ((len (babel:string-size-in-octets ,val :encoding :utf-8)))
662 (i+ (varint-length ,tag) (varint-length len) len)))
664 `(let ((len (length ,val)))
665 (i+ (varint-length ,tag) (varint-length len) len)))
667 `(i+ (varint-length ,tag) 1))
669 `(i+ (varint-length ,tag) 4))
671 `(i+ (varint-length ,tag) 8))))
674 (defun packed-size (values type tag &optional vectorp)
675 "Returns the size in bytes that the packed object will take when serialized.
676 Watch out, this function turns off most type checking."
677 (declare (ignore vectorp)
678 (type (unsigned-byte 32) tag))
679 (locally (declare #.$optimize-serialization)
680 (let ((len (let ((len 0))
681 (declare (type fixnum len))
682 (map () #'(lambda (val)
683 (iincf len (ecase type
684 ((:int32 :uint32 :int64 :uint64) (varint-length val))
685 ((:sint32) (varint-length (zig-zag-encode32 val)))
686 ((:sint64) (varint-length (zig-zag-encode64 val)))
687 ((:fixed32 :sfixed32) 4)
688 ((:fixed64 :sfixed64) 8)
691 ((:double) 8)))) values)
693 (declare (type (unsigned-byte 32) len))
694 ;; Two value: the full size of the packed object, and the size
695 ;; of just the payload
696 (values (i+ (varint-length tag) (varint-length len) len) len))))
698 ;; The optimized serializers supply 'vectorp' so we can generate better code
699 (define-compiler-macro packed-size (&whole form values type tag
700 &optional (vectorp nil vectorp-p))
701 (setq type (fold-symbol type)
702 tag (fold-symbol tag))
704 (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
705 :fixed32 :sfixed32 :fixed64 :sfixed64
706 :bool :float :double)))
707 `(locally (declare #.$optimize-serialization)
708 (let ((len (let ((len 0))
709 (declare (type fixnum len))
710 (,(if vectorp 'dovector 'dolist) (val ,values)
711 (iincf len ,(ecase type
712 ((:int32 :uint32 :int64 :uint64) `(varint-length val))
713 ((:sint32) `(varint-length (zig-zag-encode32 val)))
714 ((:sint64) `(varint-length (zig-zag-encode64 val)))
715 ((:fixed32 :sfixed32) `4)
716 ((:fixed64 :sfixed64) `8)
721 (declare (type (unsigned-byte 32) len))
722 (values (i+ (varint-length (the (unsigned-byte 32) ,tag)) (varint-length len) len) len)))
725 (defun enum-size (val enum-values tag)
726 "Returns the size in bytes that the enum object will take when serialized."
727 (declare (type list enum-values)
728 (type (unsigned-byte 32) tag))
729 (let ((idx (let ((e (find val enum-values :key #'proto-value)))
730 (and e (proto-index e)))))
732 (serialization-error "There is no enum value for ~S" val))
733 (i+ (varint-length tag) (varint-length (ldb (byte 32 0) idx)))))
735 (defun packed-enum-size (values enum-values tag)
736 "Returns the size in bytes that the enum values will take when serialized."
737 (declare (type list enum-values)
738 (type (unsigned-byte 32) tag))
739 (let ((len (let ((len 0))
740 (declare (type fixnum len))
741 (map () #'(lambda (val)
742 (let ((idx (let ((e (find val enum-values :key #'proto-value)))
743 (and e (proto-index e)))))
745 (serialization-error "There is no enum value for ~S" val))
746 (iincf len (varint-length (ldb (byte 32 0) idx))))) values)
748 (declare (type (unsigned-byte 32) len))
749 ;; Two value: the full size of the packed object, and the size
750 ;; of just the payload
751 (values (i+ (varint-length tag) (varint-length len) len) len)))
754 ;;; Wire-level encoders
755 ;;; These are called at the lowest level, so arg types are assumed to be correct
757 (defmacro generate-integer-encoders (bits)
758 "Generate 32- or 64-bit versions of integer encoders."
759 (assert (and (plusp bits) (zerop (mod bits 8))))
760 (let* ((encode-uint (fintern "~A~A" 'encode-uint bits))
761 (encode-fixed (fintern "~A~A" 'encode-fixed bits))
762 (encode-sfixed (fintern "~A~A" 'encode-sfixed bits))
764 ;; Given bits, can we use fixnums safely?
765 (fixnump (<= bits (integer-length most-negative-fixnum)))
766 (ldb (if fixnump 'ildb 'ldb))
767 (ash (if fixnump 'iash 'ash))
768 (zerop-val (if fixnump '(i= val 0) '(zerop val))))
770 (defun ,encode-uint (val buffer index)
772 "Encodes the unsigned ~A-bit integer 'val' as a varint into the buffer at the given index.~
773 ~& Modifies the buffer, and returns the new index into the buffer.~
774 ~& Watch out, this function turns off all type checking and array bounds checking." bits)
775 (declare #.$optimize-serialization)
776 (let ((val (ldb (byte ,bits 0) val)))
777 (declare (type (unsigned-byte ,bits) val)
778 (type (simple-array (unsigned-byte 8)) buffer)
780 ;; Seven bits at a time, least significant bits first
781 (loop do (let ((bits (,ldb (byte 7 0) val)))
782 (declare (type (unsigned-byte 8) bits))
783 (setq val (,ash val -7))
784 (setf (aref buffer index)
785 (ilogior bits (if ,zerop-val 0 128)))
788 (values index buffer)) ;return the buffer to improve 'trace'
789 (defun ,encode-fixed (val buffer index)
791 "Encodes the unsigned ~A-bit integer 'val' as a fixed int into the buffer at the given index.~
792 ~& Modifies the buffer, and returns the new index into the buffer.~
793 ~& Watch out, this function turns off all type checking and array bounds checking." bits)
794 (declare #.$optimize-serialization)
795 (declare (type (unsigned-byte ,bits) val)
796 (type (simple-array (unsigned-byte 8)) buffer)
798 (loop repeat ,bytes doing
799 (let ((byte (,ldb (byte 8 0) val)))
800 (declare (type (unsigned-byte 8) byte))
801 (setq val (,ash val -8))
802 (setf (aref buffer index) byte)
804 (values index buffer))
805 (defun ,encode-sfixed (val buffer index)
807 "Encodes the signed ~A-bit integer 'val' as a fixed int into the buffer at the given index.~
808 ~& Modifies the buffer, and returns the new index into the buffer.~
809 ~& Watch out, this function turns off all type checking and array bounds checking." bits)
810 (declare #.$optimize-serialization)
811 (declare (type (signed-byte ,bits) val)
812 (type (simple-array (unsigned-byte 8)) buffer)
814 (loop repeat ,bytes doing
815 (let ((byte (,ldb (byte 8 0) val)))
816 (declare (type (unsigned-byte 8) byte))
817 (setq val (,ash val -8))
818 (setf (aref buffer index) byte)
820 (values index buffer)))))
822 (generate-integer-encoders 32)
823 (generate-integer-encoders 64)
825 (defun encode-int (val buffer index)
826 "Encodes the signed integer 'val' as a varint into the buffer at the given index.
827 Modifies the buffer, and returns the new index into the buffer.
828 Watch out, this function turns off all type checking and array bounds checking."
829 (declare #.$optimize-serialization)
830 (declare (type (simple-array (unsigned-byte 8)) buffer)
831 (type (signed-byte 64) val)
833 ;; Seven bits at a time, least significant bits first
834 (loop repeat 9 ;up to 63 bits
835 do (setf (aref buffer index) (ldb (byte 7 0) val))
836 (setq val (ash val -7))
838 do (iincf (aref buffer index) #x80)
840 finally (unless (zerop val) ;take the 64th bit as needed
841 (setf (aref buffer index) 1)
843 (serialization-error "Integer too large while encoding VarInt."))))
844 (values (iincf index) buffer)) ;return the buffer to improve 'trace'
846 (defun encode-single (val buffer index)
847 "Encodes the single float 'val' into the buffer at the given index.
848 Modifies the buffer, and returns the new index into the buffer.
849 Watch out, this function turns off all type checking and array bounds checking."
850 (declare #.$optimize-serialization)
851 (declare (type single-float val)
852 (type (simple-array (unsigned-byte 8)) buffer)
854 (let ((bits (single-float-bits val)))
855 (declare (type (signed-byte 32) bits))
857 (let ((byte (ldb (byte 8 0) bits)))
858 (declare (type (unsigned-byte 8) byte))
859 (setq bits (ash bits -8))
860 (setf (aref buffer index) byte)
862 (values index buffer))
864 (defun encode-double (val buffer index)
865 "Encodes the double float 'val' into the buffer at the given index.
866 Modifies the buffer, and returns the new index into the buffer.
867 Watch out, this function turns off all type checking and array bounds checking."
868 (declare #.$optimize-serialization)
869 (declare (type double-float val)
870 (type (simple-array (unsigned-byte 8)) buffer)
872 (multiple-value-bind (low high)
873 (double-float-bits val)
874 (declare (type (unsigned-byte 32) low)
875 (type (signed-byte 32) high))
877 (let ((byte (ldb (byte 8 0) low)))
878 (declare (type (unsigned-byte 8) byte))
879 (setq low (ash low -8))
880 (setf (aref buffer index) byte)
883 (let ((byte (ldb (byte 8 0) high)))
884 (declare (type (unsigned-byte 8) byte))
885 (setq high (ash high -8))
886 (setf (aref buffer index) byte)
888 (values index buffer))
890 (defun encode-string (string buffer index)
891 "Encodes the octets into the buffer at the given index.
892 Modifies the buffer, and returns the new index into the buffer.
893 Watch out, this function turns off all type checking and array bounds checking."
894 (declare #.$optimize-serialization)
895 (declare (type (simple-array (unsigned-byte 8)) buffer)
897 (let* ((octets (babel:string-to-octets string :encoding :utf-8))
898 (len (length octets))
899 (idx (encode-uint32 len buffer index)))
900 (declare (type (simple-array (unsigned-byte 8)) octets)
902 (type (unsigned-byte 32) idx))
903 (replace buffer octets :start1 idx)
904 (values (i+ idx len) buffer)))
906 (defun encode-octets (octets buffer index)
907 "Encodes the octets into the buffer at the given index.
908 Modifies the buffer, and returns the new index into the buffer.
909 Watch out, this function turns off all type checking and array bounds checking."
910 (declare #.$optimize-serialization)
911 (declare (type (array (unsigned-byte 8)) octets)
912 (type (simple-array (unsigned-byte 8)) buffer)
914 (let* ((len (length octets))
915 (idx (encode-uint32 len buffer index)))
916 (declare (type fixnum len)
917 (type (unsigned-byte 32) idx))
918 (replace buffer octets :start1 idx)
919 (values (i+ idx len) buffer)))
922 ;;; Wire-level decoders
923 ;;; These are called at the lowest level, so arg types are assumed to be correct
925 ;; Decode the value from the buffer at the given index,
926 ;; then return the value and new index into the buffer
927 (defmacro generate-integer-decoders (bits)
928 "Generate 32- or 64-bit versions of integer decoders."
929 (assert (and (plusp bits) (zerop (mod bits 8))))
930 (let* ((decode-uint (fintern "~A~A" 'decode-uint bits))
931 (decode-fixed (fintern "~A~A" 'decode-fixed bits))
932 (decode-sfixed (fintern "~A~A" 'decode-sfixed bits))
934 ;; Given bits, can we use fixnums safely?
935 (fixnump (<= bits (integer-length most-negative-fixnum)))
936 (ash (if fixnump 'iash 'ash))
937 (decf (if fixnump 'idecf 'decf))
938 (logior (if fixnump 'ilogior 'logior))
939 (logbitp (if fixnump 'ilogbitp 'logbitp)))
941 (defun ,decode-uint (buffer index)
943 "Decodes the next ~A-bit varint integer in the buffer at the given index.~
944 ~& Returns both the decoded value and the new index into the buffer.~
945 ~& Watch out, this function turns off all type checking and array bounds checking." bits)
946 (declare #.$optimize-serialization)
947 (declare (type (simple-array (unsigned-byte 8)) buffer)
949 ;; Seven bits at a time, least significant bits first
951 (declare (type (unsigned-byte ,bits) val))
952 (loop for places fixnum upfrom 0 by 7
953 for byte fixnum = (prog1 (aref buffer index) (iincf index))
954 do (let ((bits (ildb (byte 7 0) byte)))
955 (declare (type (unsigned-byte 8) bits))
956 (setq val (,logior val (,ash bits places))))
957 while (ilogbitp 7 byte)
959 (unless (< val ,(ash 1 bits))
960 (serialization-error "The value ~D is longer than ~A bits" val ,bits))
961 (return (values val index))))))
962 (defun ,decode-fixed (buffer index)
964 "Decodes the next ~A-bit unsigned fixed integer in the buffer at the given index.~
965 ~& Returns both the decoded value and the new index into the buffer.~
966 ~& Watch out, this function turns off all type checking and array bounds checking." bits)
967 (declare #.$optimize-serialization)
968 (declare (type (simple-array (unsigned-byte 8)) buffer)
970 ;; Eight bits at a time, least significant bits first
972 ,@(when fixnump `((declare (type fixnum val))))
974 for places fixnum upfrom 0 by 8
975 for byte fixnum = (prog1 (aref buffer index) (iincf index))
976 do (setq val (,logior val (,ash byte places))))
978 (defun ,decode-sfixed (buffer index)
980 "Decodes the next ~A-bit signed fixed integer in the buffer at the given index.~
981 ~& Returns both the decoded value and the new index into the buffer.~
982 ~& Watch out, this function turns off all type checking and array bounds checking." bits)
983 (declare #.$optimize-serialization)
984 (declare (type (simple-array (unsigned-byte 8)) buffer)
986 ;; Eight bits at a time, least significant bits first
988 ,@(when fixnump `((declare (type fixnum val))))
990 for places fixnum upfrom 0 by 8
991 for byte fixnum = (prog1 (aref buffer index) (iincf index))
992 do (setq val (,logior val (,ash byte places))))
993 (when (,logbitp ,(1- bits) val) ;sign bit set, so negative value
994 (,decf val ,(ash 1 bits)))
995 (values val index))))))
997 (generate-integer-decoders 32)
998 (generate-integer-decoders 64)
1000 (defun decode-int (buffer index)
1001 "Decodes the next varint integer in the buffer at the given index.
1002 Returns both the decoded value and the new index into the buffer.
1003 Watch out, this function turns off all type checking and array bounds checking."
1004 (declare #.$optimize-serialization)
1005 (declare (type (simple-array (unsigned-byte 8)) buffer)
1006 (type fixnum index))
1007 (multiple-value-bind (val index)
1008 (decode-uint64 buffer index)
1009 (when (logbitp 63 val)
1010 (decf val #.(ash 1 64)))
1011 (values val index)))
1013 (defun decode-single (buffer index)
1014 "Decodes the next single float in the buffer at the given index.
1015 Returns both the decoded value and the new index into the buffer.
1016 Watch out, this function turns off all type checking and array bounds checking."
1017 (declare #.$optimize-serialization)
1018 (declare (type (simple-array (unsigned-byte 8)) buffer)
1019 (type fixnum index))
1020 ;; Eight bits at a time, least significant bits first
1022 (declare (type (unsigned-byte 32) bits))
1024 for places fixnum upfrom 0 by 8
1025 for byte fixnum = (prog1 (aref buffer index) (iincf index))
1026 do (setq bits (logior bits (ash byte places))))
1027 (values (make-single-float (if (logbitp 31 bits) ;sign bit
1028 (- bits #.(ash 1 32))
1032 (defun decode-double (buffer index)
1033 "Decodes the next double float in the buffer at the given index.
1034 Returns both the decoded value and the new index into the buffer.
1035 Watch out, this function turns off all type checking and array bounds checking."
1036 (declare #.$optimize-serialization)
1037 (declare (type (simple-array (unsigned-byte 8)) buffer)
1038 (type fixnum index))
1039 ;; Eight bits at a time, least significant bits first
1042 (declare (type (unsigned-byte 32) low)
1043 (type (unsigned-byte 32) high))
1045 for places fixnum upfrom 0 by 8
1046 for byte fixnum = (prog1 (aref buffer index) (iincf index))
1047 do (setq low (logior low (ash byte places))))
1049 for places fixnum upfrom 0 by 8
1050 for byte fixnum = (prog1 (aref buffer index) (iincf index))
1051 do (setq high (logior high (ash byte places))))
1052 ;; High bits are signed, but low bits are unsigned
1053 (values (make-double-float low (if (logbitp 31 high) ;sign bit
1054 (- high #.(ash 1 32))
1058 (defun decode-string (buffer index)
1059 "Decodes the next UTF-8 encoded string in the buffer at the given index.
1060 Returns both the decoded string and the new index into the buffer.
1061 Watch out, this function turns off all type checking and array bounds checking."
1062 (declare #.$optimize-serialization)
1063 (declare (type (simple-array (unsigned-byte 8)) buffer)
1064 (type fixnum index))
1065 (multiple-value-bind (len idx)
1066 (decode-uint32 buffer index)
1067 (declare (type (unsigned-byte 32) len)
1069 (values (babel:octets-to-string buffer :start idx :end (i+ idx len) :encoding :utf-8) (i+ idx len))))
1071 (defun decode-octets (buffer index)
1072 "Decodes the next octets in the buffer at the given index.
1073 Returns both the decoded value and the new index into the buffer.
1074 Watch out, this function turns off all type checking and array bounds checking."
1075 (declare #.$optimize-serialization)
1076 (declare (type (simple-array (unsigned-byte 8)) buffer)
1077 (type fixnum index))
1078 (multiple-value-bind (len idx)
1079 (decode-uint32 buffer index)
1080 (declare (type (unsigned-byte 32) len)
1082 (values (subseq buffer idx (i+ idx len)) (i+ idx len))))
1085 ;;; Wire-level lengths
1086 ;;; These are called at the lowest level, so arg types are assumed to be correct
1088 (defun varint-length (val)
1089 "Return the length that 'val' will take when encoded as a varint integer."
1090 (declare #.$optimize-serialization)
1091 (loop repeat 10 ;max length of varint
1092 do (setq val (ash val -7))
1096 ;;; Skipping elements
1097 ;;; This is called at the lowest level, so arg types are assumed to be correct
1099 (defun skip-element (buffer index tag)
1100 "Skip an element in the buffer at the index of the given wire type.
1101 Returns the new index in the buffer.
1102 Watch out, this function turns off all type checking and all array bounds checking."
1103 (declare #.$optimize-serialization)
1104 (declare (type (simple-array (unsigned-byte 8)) buffer)
1106 (type (unsigned-byte 32) tag))
1107 (case (ilogand tag #x7)
1108 ((#.$wire-type-varint)
1109 (loop for byte fixnum = (prog1 (aref buffer index) (iincf index))
1110 until (i< byte 128))
1112 ((#.$wire-type-string)
1113 (multiple-value-bind (len idx)
1114 (decode-uint32 buffer index)
1115 (declare (type (unsigned-byte 32) len)
1118 ((#.$wire-type-32bit)
1120 ((#.$wire-type-64bit)
1122 ((#.$wire-type-start-group)
1123 (loop (multiple-value-bind (new-tag idx)
1124 (decode-uint32 buffer index)
1125 (cond ((not (i= (ilogand new-tag #x7) $wire-type-end-group))
1126 ;; If it's not the end of a group, skip the next element
1127 (setq index (skip-element buffer idx new-tag)))
1128 ;; If it's the end of the expected group, we're done
1129 ((i= (i- tag $wire-type-start-group) (i- new-tag $wire-type-end-group))
1132 (unless (i= (i- tag $wire-type-start-group) (i- new-tag $wire-type-end-group))
1133 (serialization-error "Couldn't find a matching end group tag")))))))