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 (defconstant $wire-type-varint 0)
19 (defconstant $wire-type-64bit 1)
20 (defconstant $wire-type-string 2)
21 (defconstant $wire-type-start-group 3) ;supposedly obsolete
22 (defconstant $wire-type-end-group 4) ;supposedly obsolete
23 (defconstant $wire-type-32bit 5)
25 (defun make-tag (type index)
26 "Given a wire type or the name of a Protobufs type and a field index,
27 return the tag that encodes both of them."
28 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
29 (if (typep type 'fixnum)
31 (let ((type (ecase type
32 ((:int32 :uint32) $wire-type-varint)
33 ((:int64 :uint64) $wire-type-varint)
34 ((:sint32 :sint64) $wire-type-varint)
35 ((:fixed32 :sfixed32) $wire-type-32bit)
36 ((:fixed64 :sfixed64) $wire-type-64bit)
37 ((:string :bytes) $wire-type-string)
38 ((:bool) $wire-type-varint)
39 ((:float) $wire-type-32bit)
40 ((:double) $wire-type-64bit)
41 ;; A few of our homegrown types
42 ((:symbol) $wire-type-string)
43 ((:date :time :datetime :timestamp) $wire-type-64bit))))
44 (ilogior type (iash index 3))))))
46 (define-compiler-macro make-tag (&whole form type index)
47 (cond ((typep type 'fixnum)
48 `(ilogior ,type (iash ,index 3)))
50 (let ((type (ecase type
51 ((:int32 :uint32) $wire-type-varint)
52 ((:int64 :uint64) $wire-type-varint)
53 ((:sint32 :sint64) $wire-type-varint)
54 ((:fixed32 :sfixed32) $wire-type-32bit)
55 ((:fixed64 :sfixed64) $wire-type-64bit)
56 ((:string :bytes) $wire-type-string)
57 ((:bool) $wire-type-varint)
58 ((:float) $wire-type-32bit)
59 ((:double) $wire-type-64bit)
60 ;; A few of our homegrown types
61 ((:symbol) $wire-type-string)
62 ((:date :time :datetime :timestamp) $wire-type-64bit))))
63 `(ilogior ,type (iash ,index 3))))
67 (defun zig-zag-encode32 (val)
68 (declare (optimize (speed 3) (safety 0) (debug 0)))
69 (declare (type (signed-byte 32) val))
70 (logxor (ash val 1) (ash val -31)))
72 (defun zig-zag-encode64 (val)
73 (declare (optimize (speed 3) (safety 0) (debug 0)))
74 (declare (type (signed-byte 64) val))
75 (logxor (ash val 1) (ash val -63)))
77 (define-compiler-macro zig-zag-encode32 (&whole form val)
79 `(locally (declare (optimize (speed 3) (safety 0) (debug 0))
80 (type (signed-byte 32) ,val))
81 (logxor (ash ,val 1) (ash ,val -31)))
84 (define-compiler-macro zig-zag-encode64 (&whole form val)
86 `(locally (declare (optimize (speed 3) (safety 0) (debug 0))
87 (type (signed-byte 64) ,val))
88 (logxor (ash ,val 1) (ash ,val -63)))
91 (defun zig-zag-decode32 (val)
92 (declare (optimize (speed 3) (safety 0) (debug 0)))
93 (logxor (ash val -1) (- (logand val 1))))
95 (defun zig-zag-decode64 (val)
96 (declare (optimize (speed 3) (safety 0) (debug 0)))
97 (logxor (ash val -1) (- (logand val 1))))
99 (define-compiler-macro zig-zag-decode32 (&whole form val)
101 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
102 (logxor (ash ,val -1) (- (logand ,val 1))))
105 (define-compiler-macro zig-zag-decode64 (&whole form val)
107 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
108 (logxor (ash ,val -1) (- (logand ,val 1))))
114 ;; Serialize 'val' of primitive type 'type' into the buffer
115 (defun serialize-prim (val type tag buffer index)
116 "Serializes a Protobufs primitive (scalar) value into the buffer at the given index.
117 The value is given by 'val', the primitive type by 'type'.
118 Modifies the buffer in place, and returns the new index into the buffer.
119 Watch out, this function turns off most type checking and all array bounds checking."
120 (declare (type (simple-array (unsigned-byte 8)) buffer)
121 (type (unsigned-byte 32) tag)
123 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
124 (let ((idx (encode-uint32 tag buffer index)))
125 (declare (type fixnum idx))
128 (encode-uint32 val buffer idx))
130 (encode-uint64 val buffer idx))
132 (encode-uint32 (zig-zag-encode32 val) buffer idx))
134 (encode-uint64 (zig-zag-encode64 val) buffer idx))
136 (encode-fixed32 val buffer idx))
138 (encode-sfixed32 val buffer idx))
140 (encode-fixed64 val buffer idx))
142 (encode-sfixed64 val buffer idx))
144 (encode-string val buffer idx))
146 (encode-octets val buffer idx))
148 (encode-uint32 (if val 1 0) buffer idx))
150 (encode-single val buffer idx))
152 (encode-double val buffer idx))
153 ;; A few of our homegrown types
155 (let ((val (if (keywordp val)
157 ;; Non-keyword symbols are consy, avoid them if possible
158 (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val)))))
159 (encode-string val buffer idx)))
160 ((:date :time :datetime :timestamp)
161 (encode-uint64 val buffer idx))))))
163 (define-compiler-macro serialize-prim (&whole form val type tag buffer index)
164 (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
165 :fixed32 :sfixed32 :fixed64 :sfixed64
166 :string :bytes :bool :float :double))
167 `(locally (declare (optimize (speed 3) (safety 0) (debug 0))
168 (type (simple-array (unsigned-byte 8)) ,buffer)
169 ;; 'tag' is a constant, no need to declare its type
170 (type fixnum ,index))
171 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
172 (declare (type fixnum idx))
175 `(encode-uint32 ,val ,buffer idx))
177 `(encode-uint64 ,val ,buffer idx))
179 `(encode-uint32 (zig-zag-encode32 ,val) ,buffer idx))
181 `(encode-uint64 (zig-zag-encode64 ,val) ,buffer idx))
183 `(encode-fixed32 ,val ,buffer idx))
185 `(encode-sfixed32 ,val ,buffer idx))
187 `(encode-fixed64 ,val ,buffer idx))
189 `(encode-sfixed64 ,val ,buffer idx))
191 `(encode-string ,val ,buffer idx))
193 `(encode-octets ,val ,buffer idx))
195 `(encode-uint32 (if ,val 1 0) ,buffer idx))
197 `(encode-single ,val ,buffer idx))
199 `(encode-double ,val ,buffer idx)))))
202 (defun serialize-packed (values type tag buffer index)
203 "Serializes a set of packed values into the buffer at the given index.
204 The values are given by 'values', the primitive type by 'type'.
205 Modifies the buffer in place, and returns the new index into the buffer.
206 Watch out, this function turns off most type checking and all array bounds checking."
207 (declare (type (simple-array (unsigned-byte 8)) buffer)
208 (type (unsigned-byte 32) tag)
210 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
211 (let ((idx (encode-uint32 tag buffer index)))
212 (declare (type fixnum idx))
213 (multiple-value-bind (full-len len)
214 (packed-size values type tag)
215 (declare (type fixnum len) (ignore full-len))
216 (setq idx (encode-uint32 len buffer idx)))
219 (dolist (val values idx)
220 (setq idx (encode-uint32 val buffer idx))))
222 (dolist (val values idx)
223 (setq idx (encode-uint64 val buffer idx))))
225 (dolist (val values idx)
226 (setq idx (encode-uint32 (zig-zag-encode32 val) buffer idx))))
228 (dolist (val values idx)
229 (setq idx (encode-uint64 (zig-zag-encode64 val) buffer idx))))
231 (dolist (val values idx)
232 (setq idx (encode-fixed32 val buffer idx))))
234 (dolist (val values idx)
235 (setq idx (encode-sfixed32 val buffer idx))))
237 (dolist (val values idx)
238 (setq idx (encode-fixed64 val buffer idx))))
240 (dolist (val values idx)
241 (setq idx (encode-sfixed64 val buffer idx))))
243 (dolist (val values idx)
244 (setq idx (encode-single val buffer idx))))
246 (dolist (val values idx)
247 (setq idx (encode-double val buffer idx))))))))
249 (define-compiler-macro serialize-packed (&whole form values type tag buffer index)
250 (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
251 :fixed32 :sfixed32 :fixed64 :sfixed64
253 `(locally (declare (optimize (speed 3) (safety 0) (debug 0))
254 (type (simple-array (unsigned-byte 8)) ,buffer)
255 (type fixnum ,index))
256 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
257 (declare (type fixnum idx))
258 (multiple-value-bind (full-len len)
259 (packed-size ,values ,type ,tag)
260 (declare (type fixnum len) (ignore full-len))
261 (setq idx (encode-uint32 len ,buffer idx)))
262 (dolist (val ,values idx)
265 `(setq idx (encode-uint32 val ,buffer idx)))
267 `(setq idx (encode-uint64 val ,buffer idx)))
269 `(setq idx (encode-uint32 (zig-zag-encode32 val) ,buffer idx)))
271 `(setq idx (encode-uint64 (zig-zag-encode64 val) ,buffer idx)))
273 `(setq idx (encode-fixed32 val ,buffer idx)))
275 `(setq idx (encode-sfixed32 val ,buffer idx)))
277 `(setq idx (encode-fixed64 val ,buffer idx)))
279 `(setq idx (encode-sfixed64 val ,buffer idx)))
281 `(setq idx (encode-single val ,buffer idx)))
283 `(setq idx (encode-double val ,buffer idx)))))))
286 (defun serialize-enum (val values tag buffer index)
287 "Serializes a Protobufs enum value into the buffer at the given index.
288 The value is given by 'val', the enum values are in 'values'.
289 Modifies the buffer in place, and returns the new index into the buffer.
290 Watch out, this function turns off most type checking and all array bounds checking."
291 (declare (type (simple-array (unsigned-byte 8)) buffer)
292 (type (unsigned-byte 32) tag)
294 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
295 (let* ((val (let ((e (find val values :key #'proto-value)))
296 (and e (proto-index e))))
297 (idx (encode-uint32 tag buffer index)))
298 (declare (type (unsigned-byte 32) val)
300 (encode-uint32 val buffer idx))))
305 ;; Deserialize the next object of type 'type'
306 (defun deserialize-prim (type buffer index)
307 "Deserializes the next object of primitive type 'type'.
308 Deserializes from the byte vector 'buffer' starting at 'index'.
309 Returns the value and and the new index into the buffer.
310 Watch out, this function turns off most type checking and all array bounds checking."
311 (declare (type (simple-array (unsigned-byte 8)) buffer)
313 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
316 (decode-uint32 buffer index))
318 (decode-uint64 buffer index))
320 (multiple-value-bind (val idx)
321 (decode-uint32 buffer index)
322 (values (zig-zag-decode32 val) idx)))
324 (multiple-value-bind (val idx)
325 (decode-uint64 buffer index)
326 (values (zig-zag-decode64 val) idx)))
328 (decode-fixed32 buffer index))
330 (decode-sfixed32 buffer index))
332 (decode-fixed64 buffer index))
334 (decode-sfixed64 buffer index))
336 (decode-string buffer index))
338 (decode-octets buffer index))
340 (multiple-value-bind (val idx)
341 (decode-uint32 buffer index)
342 (values (if (i= val 0) nil t) idx)))
344 (decode-single buffer index))
346 (decode-double buffer index))
347 ;; A few of our homegrown types
349 ;; Note that this is consy, avoid it if possible
350 (multiple-value-bind (val idx)
351 (decode-string buffer index)
352 (values (make-lisp-symbol val) idx)))
353 ((:date :time :datetime :timestamp)
354 (decode-uint64 buffer index)))))
356 (define-compiler-macro deserialize-prim (&whole form type buffer index)
357 (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
358 :fixed32 :sfixed32 :fixed64 :sfixed64
359 :string :bytes :bool :float :double))
360 `(locally (declare (optimize (speed 3) (safety 0) (debug 0))
361 (type (simple-array (unsigned-byte 8)) ,buffer)
362 (type fixnum ,index))
365 `(decode-uint32 ,buffer ,index))
367 `(decode-uint64 ,buffer ,index))
369 `(multiple-value-bind (val idx)
370 (decode-uint32 ,buffer ,index)
371 (values (zig-zag-decode32 val) idx)))
373 `(multiple-value-bind (val idx)
374 (decode-uint64 ,buffer ,index)
375 (values (zig-zag-decode64 val) idx)))
377 `(decode-fixed32 ,buffer ,index))
379 `(decode-sfixed32 ,buffer ,index))
381 `(decode-fixed64 ,buffer ,index))
383 `(decode-sfixed64 ,buffer ,index))
385 `(decode-string ,buffer ,index))
387 `(decode-octets ,buffer ,index))
389 `(multiple-value-bind (val idx)
390 (decode-uint32 ,buffer ,index)
391 (values (if (i= val 0) nil t) idx)))
393 `(decode-single ,buffer ,index))
395 `(decode-double ,buffer ,index))))
398 (defun deserialize-packed (type buffer index)
399 "Deserializes the next packed values of type 'type'.
400 Deserializes from the byte vector 'buffer' starting at 'index'.
401 Returns the value and and the new index into the buffer.
402 Watch out, this function turns off most type checking and all array bounds checking."
403 (declare (type (simple-array (unsigned-byte 8)) buffer)
405 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
406 (multiple-value-bind (len idx)
407 (decode-uint32 buffer index)
408 (declare (type (unsigned-byte 32) len)
410 (let ((end (i+ idx len)))
411 (declare (type (unsigned-byte 32) end))
412 (with-collectors ((values collect-value))
415 (return-from deserialize-packed (values values idx)))
416 (multiple-value-bind (val nidx)
419 (decode-uint32 buffer idx))
421 (decode-uint64 buffer idx))
423 (multiple-value-bind (val idx)
424 (decode-uint32 buffer idx)
425 (values (zig-zag-decode32 val) idx)))
427 (multiple-value-bind (val idx)
428 (decode-uint64 buffer idx)
429 (values (zig-zag-decode64 val) idx)))
431 (decode-fixed32 buffer idx))
433 (decode-sfixed32 buffer idx))
435 (decode-fixed64 buffer idx))
437 (decode-sfixed64 buffer idx))
439 (decode-single buffer idx))
441 (decode-double buffer idx)))
443 (setq idx nidx))))))))
445 (define-compiler-macro deserialize-packed (&whole form type buffer index)
446 (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
447 :fixed32 :sfixed32 :fixed64 :sfixed64
449 `(locally (declare (optimize (speed 3) (safety 0) (debug 0))
450 (type (simple-array (unsigned-byte 8)) ,buffer)
451 (type fixnum ,index))
452 (multiple-value-bind (len idx)
453 (decode-uint32 .buffer ,index)
454 (declare (type (unsigned-byte 32) len)
456 (let ((end (i+ idx len)))
457 (declare (type (unsigned-byte 32) end))
458 (with-collectors ((values collect-value))
461 (return-from deserialize-packed (values values idx)))
462 (multiple-value-bind (val nidx)
465 `(decode-uint32 ,buffer idx))
467 `(decode-uint64 ,buffer idx))
469 `(multiple-value-bind (val idx)
470 (decode-uint32 ,buffer idx)
471 (values (zig-zag-decode32 val) idx)))
473 `(multiple-value-bind (val idx)
474 (decode-uint64 ,buffer idx)
475 (values (zig-zag-decode64 val) idx)))
477 `(decode-fixed32 ,buffer idx))
479 `(decode-sfixed32 ,buffer idx))
481 `(decode-fixed64 ,buffer idx))
483 `(decode-sfixed64 ,buffer idx))
485 `(decode-single ,buffer idx))
487 `(decode-double ,buffer idx)))
489 (setq idx nidx)))))))
492 (defun deserialize-enum (values buffer index)
493 "Deserializes the next enum value take from 'values'.
494 Deserializes from the byte vector 'buffer' starting at 'index'.
495 Returns the value and and the new index into the buffer.
496 Watch out, this function turns off most type checking and all array bounds checking."
497 (declare (type (simple-array (unsigned-byte 8)) buffer)
499 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
500 (multiple-value-bind (val idx)
501 (decode-uint32 buffer index)
502 (let ((val (let ((e (find val values :key #'proto-index)))
503 (and e (proto-value e)))))
509 (defun prim-size (val type tag)
510 "Returns the size in bytes that the primitive object will take when serialized.
511 Watch out, this function turns off most type checking."
512 (declare (type (unsigned-byte 32) tag))
513 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
516 (i+ (length32 tag) (length32 val)))
518 (i+ (length32 tag) (length64 val)))
520 (i+ (length32 tag) (length32 (zig-zag-encode32 val))))
522 (i+ (length32 tag) (length64 (zig-zag-encode64 val))))
523 ((:fixed32 :sfixed32)
524 (i+ (length32 tag) 4))
525 ((:fixed64 :sfixed64)
526 (i+ (length32 tag) 8))
528 (let ((len (babel:string-size-in-octets val :encoding :utf-8)))
529 (i+ (length32 tag) (length32 len) len)))
531 (let ((len (length val)))
532 (i+ (length32 tag) (length32 len) len)))
534 (i+ (length32 tag) 1))
536 (i+ (length32 tag) 4))
538 (i+ (length32 tag) 8))
539 ;; A few of our homegrown types
541 (let ((len (if (keywordp val)
542 (length (symbol-name val))
543 (i+ (length (package-name (symbol-package val))) 1 (length (symbol-name val))))))
544 (i+ (length32 tag) (length32 len) len)))
545 ((:date :time :datetime :timestamp)
546 (i+ (length32 tag) 8)))))
548 (define-compiler-macro prim-size (&whole form val type tag)
549 (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
550 :fixed32 :sfixed32 :fixed64 :sfixed64
551 :string :bytes :bool :float :double))
552 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
555 `(i+ (length32 ,tag) (length32 ,val)))
557 `(i+ (length32 ,tag) (length64 ,val)))
559 `(i+ (length32 ,tag) (length32 (zig-zag-encode32 ,val))))
561 `(i+ (length32 ,tag) (length64 (zig-zag-encode64 ,val))))
562 ((:fixed32 :sfixed32)
563 `(i+ (length32 ,tag) 4))
564 ((:fixed64 :sfixed64)
565 `(i+ (length32 ,tag) 8))
567 `(let ((len (babel:string-size-in-octets ,val :encoding :utf-8)))
568 (i+ (length32 ,tag) (length32 len) len)))
570 `(let ((len (length ,val)))
571 (i+ (length32 ,tag) (length32 len) len)))
573 `(i+ (length32 ,tag) 1))
575 `(i+ (length32 ,tag) 4))
577 `(i+ (length32 ,tag) 8))))
580 (defun packed-size (values type tag)
581 "Returns the size in bytes that the packed object will take when serialized.
582 Watch out, this function turns off most type checking."
583 (declare (type (unsigned-byte 32) tag))
584 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
585 (let ((len (let ((len 0))
586 (declare (type fixnum len))
587 (dolist (val values len)
588 (iincf len (ecase type
589 ((:int32 :uint32) (length32 val))
590 ((:int64 :uint64) (length64 val))
591 ((:sint32) (length32 (zig-zag-encode32 val)))
592 ((:sint64) (length64 (zig-zag-encode64 val)))
593 ((:fixed32 :sfixed32) 4)
594 ((:fixed64 :sfixed64) 8)
597 (declare (type (unsigned-byte 32) len))
598 ;; Two value: the full size of the packed object, and the size
599 ;; of just the payload
600 (values (i+ (length32 tag) (length32 len) len) len))))
602 (define-compiler-macro packed-size (&whole form values type tag)
603 (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
604 :fixed32 :sfixed32 :fixed64 :sfixed64
606 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
607 (let ((len (let ((len 0))
608 (declare (type fixnum len))
609 (dolist (val ,values len)
610 (iincf len ,(ecase type
611 ((:int32 :uint32) `(length32 val))
612 ((:int64 :uint64) `(length64 val))
613 ((:sint32) `(length32 (zig-zag-encode32 val)))
614 ((:sint64) `(length64 (zig-zag-encode64 val)))
615 ((:fixed32 :sfixed32) `4)
616 ((:fixed64 :sfixed64) `8)
619 (declare (type (unsigned-byte 32) len))
620 (values (i+ (length32 (the (unsigned-byte 32) ,tag)) (length32 len) len) len)))
623 (defun enum-size (val values tag)
624 "Returns the size in bytes that the enum object will take when serialized."
625 (declare (type (unsigned-byte 32) tag))
626 (let ((idx (let ((e (find val values :key #'proto-value)))
627 (and e (proto-index e)))))
628 (assert idx () "There is no enum value for ~S" val)
629 (i+ (length32 tag) (length32 idx))))
633 ;;; These are called at the lowest level, so arg types are assumed to be correct
635 (defun encode-uint32 (val buffer index)
636 "Encodes the unsigned 32-bit integer 'val' as a varint into the buffer
638 Modifies the buffer, and returns the new index into the buffer.
639 Watch out, this function turns off all type checking and array bounds checking."
640 (declare (optimize (speed 3) (safety 0) (debug 0)))
641 (declare (type (unsigned-byte 32) val)
642 (type (simple-array (unsigned-byte 8)) buffer)
644 ;; Seven bits at a time, least significant bits first
645 (loop do (let ((bits (ildb (byte 7 0) val)))
646 (declare (type (unsigned-byte 8) bits))
647 (setq val (iash val -7))
648 (setf (aref buffer index) (ilogior bits (if (i= val 0) 0 128)))
651 (values index buffer)) ;return the buffer to improve 'trace'
653 (defun encode-uint64 (val buffer index)
654 "Encodes the unsigned 64-bit integer 'val' as a varint into the buffer
656 Modifies the buffer, and returns the new index into the buffer.
657 Watch out, this function turns off all type checking and array bounds checking."
658 (declare (optimize (speed 3) (safety 0) (debug 0)))
659 (declare (type (unsigned-byte 64) val)
660 (type (simple-array (unsigned-byte 8)) buffer)
662 (loop do (let ((bits (ldb (byte 7 0) val)))
663 (declare (type (unsigned-byte 8) bits))
664 (setq val (ash val -7))
665 (setf (aref buffer index) (ilogior bits (if (zerop val) 0 128)))
668 (values index buffer))
670 (defun encode-fixed32 (val buffer index)
671 "Encodes the unsigned 32-bit integer 'val' as a fixed int into the buffer
673 Modifies the buffer, and returns the new index into the buffer.
674 Watch out, this function turns off all type checking and array bounds checking."
675 (declare (optimize (speed 3) (safety 0) (debug 0)))
676 (declare (type (unsigned-byte 32) val)
677 (type (simple-array (unsigned-byte 8)) buffer)
680 (let ((byte (ildb (byte 8 0) val)))
681 (declare (type (unsigned-byte 8) byte))
682 (setq val (iash val -8))
683 (setf (aref buffer index) byte)
685 (values index buffer))
687 (defun encode-fixed64 (val buffer index)
688 "Encodes the unsigned 64-bit integer 'val' as a fixed int into the buffer
690 Modifies the buffer, and returns the new index into the buffer.
691 Watch out, this function turns off all type checking and array bounds checking."
692 (declare (optimize (speed 3) (safety 0) (debug 0)))
693 (declare (type (unsigned-byte 64) val)
694 (type (simple-array (unsigned-byte 8)) buffer)
697 (let ((byte (ldb (byte 8 0) val)))
698 (declare (type (unsigned-byte 8) byte))
699 (setq val (ash val -8))
700 (setf (aref buffer index) byte)
702 (values index buffer))
704 (defun encode-sfixed32 (val buffer index)
705 "Encodes the signed 32-bit integer 'val' as a fixed int into the buffer
707 Modifies the buffer, and returns the new index into the buffer.
708 Watch out, this function turns off all type checking and array bounds checking."
709 (declare (optimize (speed 3) (safety 0) (debug 0)))
710 (declare (type (signed-byte 32) val)
711 (type (simple-array (unsigned-byte 8)) buffer)
714 (let ((byte (ildb (byte 8 0) val)))
715 (declare (type (unsigned-byte 8) byte))
716 (setq val (iash val -8))
717 (setf (aref buffer index) byte)
719 (values index buffer))
721 (defun encode-sfixed64 (val buffer index)
722 "Encodes the signed 64-bit integer 'val' as a fixed int into the buffer
724 Modifies the buffer, and returns the new index into the buffer.
725 Watch out, this function turns off all type checking and array bounds checking."
726 (declare (optimize (speed 3) (safety 0) (debug 0)))
727 (declare (type (signed-byte 64) val)
728 (type (simple-array (unsigned-byte 8)) buffer)
731 (let ((byte (ldb (byte 8 0) val)))
732 (declare (type (unsigned-byte 8) byte))
733 (setq val (ash val -8))
734 (setf (aref buffer index) byte)
736 (values index buffer))
738 (defun encode-single (val buffer index)
739 "Encodes the single float 'val' into the buffer at the given index.
740 Modifies the buffer, and returns the new index into the buffer.
741 Watch out, this function turns off all type checking and array bounds checking."
742 (declare (optimize (speed 3) (safety 0) (debug 0)))
743 (declare (type single-float val)
744 (type (simple-array (unsigned-byte 8)) buffer)
746 (let ((bits (single-float-bits val)))
748 (let ((byte (ldb (byte 8 0) bits)))
749 (declare (type (unsigned-byte 8) byte))
750 (setq bits (ash bits -8))
751 (setf (aref buffer index) byte)
753 (values index buffer))
755 (defun encode-double (val buffer index)
756 "Encodes the double float 'val' into the buffer at the given index.
757 Modifies the buffer, and returns the new index into the buffer.
758 Watch out, this function turns off all type checking and array bounds checking."
759 (declare (optimize (speed 3) (safety 0) (debug 0)))
760 (declare (type double-float val)
761 (type (simple-array (unsigned-byte 8)) buffer)
763 (multiple-value-bind (low high)
764 (double-float-bits val)
766 (let ((byte (ldb (byte 8 0) low)))
767 (declare (type (unsigned-byte 8) byte))
768 (setq low (ash low -8))
769 (setf (aref buffer index) byte)
772 (let ((byte (ldb (byte 8 0) high)))
773 (declare (type (unsigned-byte 8) byte))
774 (setq high (ash high -8))
775 (setf (aref buffer index) byte)
777 (values index buffer))
779 (defun encode-string (string buffer index)
780 "Encodes the octets into the buffer at the given index.
781 Modifies the buffer, and returns the new index into the buffer.
782 Watch out, this function turns off all type checking and array bounds checking."
783 (declare (optimize (speed 3) (safety 0) (debug 0)))
784 (declare (type (simple-array (unsigned-byte 8)) buffer)
786 (let* ((octets (babel:string-to-octets string :encoding :utf-8))
787 (len (length octets))
788 (idx (encode-uint32 len buffer index)))
789 (declare (type fixnum len)
790 (type (unsigned-byte 32) idx))
791 (replace buffer octets :start1 idx)
792 (values (i+ idx len) buffer)))
794 (defun encode-octets (octets buffer index)
795 "Encodes the octets into the buffer at the given index.
796 Modifies the buffer, and returns the new index into the buffer.
797 Watch out, this function turns off all type checking and array bounds checking."
798 (declare (optimize (speed 3) (safety 0) (debug 0)))
799 (declare (type (simple-array (unsigned-byte 8)) buffer)
801 (let* ((len (length octets))
802 (idx (encode-uint32 len buffer index)))
803 (declare (type fixnum len)
804 (type (unsigned-byte 32) idx))
805 (replace buffer octets :start1 idx)
806 (values (i+ idx len) buffer)))
810 ;;; These are called at the lowest level, so arg types are assumed to be correct
812 ;; Decode the value from the buffer at the given index,
813 ;; then return the value and new index into the buffer
814 (defun decode-uint32 (buffer index)
815 "Decodes the next 32-bit varint integer in the buffer at the given index.
816 Returns both the decoded value and the new index into the buffer.
817 Watch out, this function turns off all type checking and array bounds checking."
818 (declare (optimize (speed 3) (safety 0) (debug 0)))
819 (declare (type (simple-array (unsigned-byte 8)) buffer)
821 ;; Seven bits at a time, least significant bits first
822 (loop with val fixnum = 0
823 for places fixnum upfrom 0 by 7
824 for byte fixnum = (prog1 (aref buffer index) (iincf index))
825 do (setq val (ilogior val (iash (ildb (byte 7 0) byte) places)))
828 (assert (< val #.(ash 1 32)) ()
829 "The value ~D is longer than 32 bits" val)
830 (return (values val index)))))
832 (defun decode-uint64 (buffer index)
833 "Decodes the next 64-bit varint integer in the buffer at the given index.
834 Returns both the decoded value and the new index into the buffer.
835 Watch out, this function turns off all type checking and array bounds checking."
836 (declare (optimize (speed 3) (safety 0) (debug 0)))
837 (declare (type (simple-array (unsigned-byte 8)) buffer)
839 ;; Seven bits at a time, least significant bits first
841 for places fixnum upfrom 0 by 7
842 for byte fixnum = (prog1 (aref buffer index) (iincf index))
843 do (setq val (logior val (ash (ildb (byte 7 0) byte) places)))
845 finally (return (values val index))))
847 (defun decode-fixed32 (buffer index)
848 "Decodes the next 32-bit unsigned fixed integer in the buffer at the given index.
849 Returns both the decoded value and the new index into the buffer.
850 Watch out, this function turns off all type checking and array bounds checking."
851 (declare (optimize (speed 3) (safety 0) (debug 0)))
852 (declare (type (simple-array (unsigned-byte 8)) buffer)
854 ;; Eight bits at a time, least significant bits first
856 (declare (type fixnum val))
858 for places fixnum upfrom 0 by 8
859 for byte fixnum = (prog1 (aref buffer index) (iincf index))
860 do (setq val (ilogior val (iash byte places))))
863 (defun decode-sfixed32 (buffer index)
864 "Decodes the next 32-bit signed fixed integer in the buffer at the given index.
865 Returns both the decoded value and the new index into the buffer.
866 Watch out, this function turns off all type checking and array bounds checking."
867 (declare (optimize (speed 3) (safety 0) (debug 0)))
868 (declare (type (simple-array (unsigned-byte 8)) buffer)
870 ;; Eight bits at a time, least significant bits first
872 (declare (type fixnum val))
874 for places fixnum upfrom 0 by 8
875 for byte fixnum = (prog1 (aref buffer index) (iincf index))
876 do (setq val (ilogior val (iash byte places))))
877 (when (i= (ldb (byte 1 31) val) 1) ;sign bit set, so negative value
878 (decf val #.(ash 1 32)))
881 (defun decode-fixed64 (buffer index)
882 "Decodes the next unsigned 64-bit fixed integer in the buffer at the given index.
883 Returns both the decoded value and the new index into the buffer.
884 Watch out, this function turns off all type checking and array bounds checking."
885 (declare (optimize (speed 3) (safety 0) (debug 0)))
886 (declare (type (simple-array (unsigned-byte 8)) buffer)
888 ;; Eight bits at a time, least significant bits first
891 for places fixnum upfrom 0 by 8
892 for byte fixnum = (prog1 (aref buffer index) (iincf index))
893 do (setq val (logior val (ash byte places))))
896 (defun decode-sfixed64 (buffer index)
897 "Decodes the next signed 64-bit fixed integer in the buffer at the given index.
898 Returns both the decoded value and the new index into the buffer.
899 Watch out, this function turns off all type checking and array bounds checking."
900 (declare (optimize (speed 3) (safety 0) (debug 0)))
901 (declare (type (simple-array (unsigned-byte 8)) buffer)
903 ;; Eight bits at a time, least significant bits first
906 for places fixnum upfrom 0 by 8
907 for byte fixnum = (prog1 (aref buffer index) (iincf index))
908 do (setq val (logior val (ash byte places))))
909 (when (i= (ldb (byte 1 63) val) 1) ;sign bit set, so negative value
910 (decf val #.(ash 1 64)))
913 (defun decode-single (buffer index)
914 "Decodes the next single float in the buffer at the given index.
915 Returns both the decoded value and the new index into the buffer.
916 Watch out, this function turns off all type checking and array bounds checking."
917 (declare (optimize (speed 3) (safety 0) (debug 0)))
918 (declare (type (simple-array (unsigned-byte 8)) buffer)
920 ;; Eight bits at a time, least significant bits first
923 for places fixnum upfrom 0 by 8
924 for byte fixnum = (prog1 (aref buffer index) (iincf index))
925 do (setq bits (logior bits (ash byte places))))
926 (when (i= (ldb (byte 1 31) bits) 1) ;sign bit set, so negative value
927 (decf bits #.(ash 1 32)))
928 (values (make-single-float bits) index)))
930 (defun decode-double (buffer index)
931 "Decodes the next double float in the buffer at the given index.
932 Returns both the decoded value and the new index into the buffer.
933 Watch out, this function turns off all type checking and array bounds checking."
934 (declare (optimize (speed 3) (safety 0) (debug 0)))
935 (declare (type (simple-array (unsigned-byte 8)) buffer)
937 ;; Eight bits at a time, least significant bits first
941 for places fixnum upfrom 0 by 8
942 for byte fixnum = (prog1 (aref buffer index) (iincf index))
943 do (setq low (logior low (ash byte places))))
945 for places fixnum upfrom 0 by 8
946 for byte fixnum = (prog1 (aref buffer index) (iincf index))
947 do (setq high (logior high (ash byte places))))
948 ;; High bits are signed, but low bits are unsigned
949 (when (i= (ldb (byte 1 31) high) 1) ;sign bit set, so negative value
950 (decf high #.(ash 1 32)))
951 (values (make-double-float low high) index)))
953 (defun decode-string (buffer index)
954 "Decodes the next UTF-8 encoded string in the buffer at the given index.
955 Returns both the decoded string and the new index into the buffer.
956 Watch out, this function turns off all type checking and array bounds checking."
957 (declare (optimize (speed 3) (safety 0) (debug 0)))
958 (declare (type (simple-array (unsigned-byte 8)) buffer)
960 (multiple-value-bind (len idx)
961 (decode-uint32 buffer index)
962 (declare (type (unsigned-byte 32) len)
964 (values (babel:octets-to-string buffer :start idx :end (i+ idx len) :encoding :utf-8) (i+ idx len))))
966 (defun decode-octets (buffer index)
967 "Decodes the next octets in the buffer at the given index.
968 Returns both the decoded value and the new index into the buffer.
969 Watch out, this function turns off all type checking and array bounds checking."
970 (declare (optimize (speed 3) (safety 0) (debug 0)))
971 (declare (type (simple-array (unsigned-byte 8)) buffer)
973 (multiple-value-bind (len idx)
974 (decode-uint32 buffer index)
975 (declare (type (unsigned-byte 32) len)
977 (values (subseq buffer idx (i+ idx len)) (i+ idx len))))
981 ;;; These are called at the lowest level, so arg types are assumed to be correct
983 (defun length32 (val)
984 "Returns the length that 'val' will take when encoded as a 32-bit integer."
985 (declare (optimize (speed 3) (safety 0) (debug 0)))
986 (declare (type (unsigned-byte 32) val))
988 (declare (type fixnum size))
990 (setq val (iash val -7))
995 (defun length64 (val)
996 "Returns the length that 'val' will take when encoded as a 64-bit integer."
997 (declare (optimize (speed 3) (safety 0) (debug 0)))
998 (declare (type (unsigned-byte 64) val))
1000 (declare (type fixnum size))
1002 (setq val (ash val -7))
1008 ;;; Skipping elements
1009 ;;; This is called at the lowest level, so arg types are assumed to be correct
1011 (defun skip-element (buffer index tag)
1012 "Skip an element in the buffer at the index of the given wire type.
1013 Returns the new index in the buffer.
1014 Watch out, this function turns off all type checking and all array bounds checking."
1015 (declare (optimize (speed 3) (safety 0) (debug 0)))
1016 (declare (type (simple-array (unsigned-byte 8)) buffer)
1018 (type (unsigned-byte 32) tag))
1019 (case (ilogand tag #x7)
1020 ((#.$wire-type-varint)
1021 (loop for byte fixnum = (prog1 (aref buffer index) (iincf index))
1022 until (i< byte 128))
1024 ((#.$wire-type-string)
1025 (multiple-value-bind (len idx)
1026 (decode-uint32 buffer index)
1027 (declare (type (unsigned-byte 32) len)
1030 ((#.$wire-type-32bit)
1032 ((#.$wire-type-64bit)
1034 ((#.$wire-type-start-group)
1035 (loop (multiple-value-bind (new-tag idx)
1036 (decode-uint32 buffer index)
1037 (cond ((not (i= (ilogand new-tag #x7) $wire-type-end-group))
1038 ;; If it's not the end of a group, skip the next element
1039 (setq index (skip-element buffer idx new-tag)))
1040 ;; If it's the end of the expected group, we're done
1041 ((i= (i- tag $wire-type-start-group) (i- new-tag $wire-type-end-group))
1044 (assert (i= (i- tag $wire-type-start-group) (i- new-tag $wire-type-end-group)) ()
1045 "Couldn't find a matching end group tag"))))))