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-32bit 5)
23 (defun make-tag (type index)
24 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
25 (if (typep type 'fixnum)
27 (let ((type (ecase type
28 ((:int32 :uint32) $wire-type-varint)
29 ((:int64 :uint64) $wire-type-varint)
30 ((:sint32 :sint64) $wire-type-varint)
31 ((:fixed32 :sfixed32) $wire-type-32bit)
32 ((:fixed64 :sfixed64) $wire-type-64bit)
33 ((:string :bytes) $wire-type-string)
34 ((:bool) $wire-type-varint)
35 ((:float) $wire-type-32bit)
36 ((:double) $wire-type-64bit)
37 ;; A few of our homegrown types
38 ((:symbol) $wire-type-string)
39 ((:date :time :datetime :timestamp) $wire-type-64bit))))
40 (ilogior type (iash index 3))))))
42 (define-compiler-macro make-tag (&whole form type index)
43 (cond ((typep type 'fixnum)
44 `(ilogior ,type (iash ,index 3)))
46 (let ((type (ecase type
47 ((:int32 :uint32) $wire-type-varint)
48 ((:int64 :uint64) $wire-type-varint)
49 ((:sint32 :sint64) $wire-type-varint)
50 ((:fixed32 :sfixed32) $wire-type-32bit)
51 ((:fixed64 :sfixed64) $wire-type-64bit)
52 ((:string :bytes) $wire-type-string)
53 ((:bool) $wire-type-varint)
54 ((:float) $wire-type-32bit)
55 ((:double) $wire-type-64bit)
56 ;; A few of our homegrown types
57 ((:symbol) $wire-type-string)
58 ((:date :time :datetime :timestamp) $wire-type-64bit))))
59 `(ilogior ,type (iash ,index 3))))
65 ;; Serialize 'val' of primitive type 'type' into the buffer
66 (defun serialize-prim (val type tag buffer index)
67 "Serializes a Protobufs primitive (scalar) value into the buffer at the given index.
68 The value is given by 'val', the primitive type by 'type'.
69 Modifies the buffer in place, and returns the new index into the buffer."
70 (declare (type (simple-array (unsigned-byte 8)) buffer)
71 (type (unsigned-byte 32) tag)
73 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
74 (let ((idx (encode-uint32 tag buffer index)))
75 (declare (type fixnum idx))
78 (encode-uint32 val buffer idx))
80 (encode-uint64 val buffer idx))
82 (encode-uint32 (zig-zag-encode32 val) buffer idx))
84 (encode-uint64 (zig-zag-encode64 val) buffer idx))
86 (encode-fixed32 val buffer idx))
88 (encode-sfixed32 val buffer idx))
90 (encode-fixed64 val buffer idx))
92 (encode-sfixed64 val buffer idx))
94 (encode-octets (babel:string-to-octets val :encoding :utf-8) buffer idx))
96 (encode-octets val buffer idx))
98 (encode-uint32 (if val 1 0) buffer idx))
100 (encode-single val buffer idx))
102 (encode-double val buffer idx))
103 ;; A few of our homegrown types
105 (let ((val (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val))))
106 ;; Call 'string' in case we are trying to serialize a symbol name
107 (encode-octets (babel:string-to-octets val :encoding :utf-8) buffer idx)))
108 ((:date :time :datetime :timestamp)
109 (encode-uint64 val buffer idx))))))
111 (define-compiler-macro serialize-prim (&whole form val type tag buffer index)
114 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
115 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
116 (declare (type fixnum idx))
117 (encode-uint32 ,val ,buffer idx))))
119 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
120 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
121 (declare (type fixnum idx))
122 (encode-uint64 ,val ,buffer idx))))
124 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
125 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
126 (declare (type fixnum idx))
127 (encode-uint32 (zig-zag-encode32 ,val) ,buffer idx))))
129 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
130 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
131 (declare (type fixnum idx))
132 (encode-uint64 (zig-zag-encode64 ,val) ,buffer idx))))
134 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
135 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
136 (declare (type fixnum idx))
137 (encode-fixed32 ,val ,buffer idx))))
139 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
140 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
141 (declare (type fixnum idx))
142 (encode-sfixed32 ,val ,buffer idx))))
144 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
145 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
146 (declare (type fixnum idx))
147 (encode-fixed64 ,val ,buffer idx))))
149 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
150 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
151 (declare (type fixnum idx))
152 (encode-sfixed64 ,val ,buffer idx))))
154 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
155 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
156 (declare (type fixnum idx))
157 (encode-octets (babel:string-to-octets ,val :encoding :utf-8) ,buffer idx))))
159 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
160 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
161 (declare (type fixnum idx))
162 (encode-octets ,val ,buffer idx))))
164 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
165 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
166 (declare (type fixnum idx))
167 (encode-uint32 (if ,val 1 0) ,buffer idx))))
169 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
170 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
171 (declare (type fixnum idx))
172 (encode-single ,val ,buffer idx))))
174 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
175 (let ((idx (encode-uint32 ,tag ,buffer ,index)))
176 (declare (type fixnum idx))
177 (encode-double ,val ,buffer idx))))
180 (defun serialize-packed (values type tag buffer index)
181 "Serializes a set of packed values into the buffer at the given index.
182 The values are given by 'values', the primitive type by 'type'.
183 Modifies the buffer in place, and returns the new index into the buffer."
184 (declare (type (simple-array (unsigned-byte 8)) buffer)
185 (type (unsigned-byte 32) tag)
187 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
188 (let ((idx (encode-uint32 tag buffer index)))
189 (declare (type fixnum idx))
190 (multiple-value-bind (full-len len)
191 (packed-size values type tag)
192 (declare (type fixnum len) (ignore full-len))
193 (setq idx (encode-uint32 len buffer idx)))
196 (dolist (val values idx)
197 (setq idx (encode-uint32 val buffer idx))))
199 (dolist (val values idx)
200 (setq idx (encode-uint64 val buffer idx))))
202 (dolist (val values idx)
203 (setq idx (encode-uint32 (zig-zag-encode32 val) buffer idx))))
205 (dolist (val values idx)
206 (setq idx (encode-uint64 (zig-zag-encode64 val) buffer idx))))
208 (dolist (val values idx)
209 (setq idx (encode-fixed32 val buffer idx))))
211 (dolist (val values idx)
212 (setq idx (encode-sfixed32 val buffer idx))))
214 (dolist (val values idx)
215 (setq idx (encode-fixed64 val buffer idx))))
217 (dolist (val values idx)
218 (setq idx (encode-sfixed64 val buffer idx))))
220 (dolist (val values idx)
221 (setq idx (encode-single val buffer idx))))
223 (dolist (val values idx)
224 (setq idx (encode-double val buffer idx))))))))
226 (defun serialize-enum (val values tag buffer index)
227 "Serializes a Protobufs enum value into the buffer at the given index.
228 The value is given by 'val', the enum values are in 'values'.
229 Modifies the buffer in place, and returns the new index into the buffer."
230 (declare (type (simple-array (unsigned-byte 8)) buffer)
231 (type (unsigned-byte 32) tag)
233 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
234 (let* ((val (let ((e (find val values :key #'proto-value)))
235 (and e (proto-index e))))
236 (idx (encode-uint32 tag buffer index)))
237 (declare (type (unsigned-byte 32) val)
239 (encode-uint32 val buffer idx))))
244 ;; Deserialize the next object of type 'type'
245 (defun deserialize-prim (type buffer index)
246 "Deserializes the next object of primitive type 'type'.
247 Deserializes from the byte vector 'buffer' starting at 'index'.
248 Returns the value and and the new index into the buffer."
249 (declare (type (simple-array (unsigned-byte 8)) buffer)
251 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
254 (decode-uint32 buffer index))
256 (decode-uint64 buffer index))
258 (multiple-value-bind (val idx)
259 (decode-uint32 buffer index)
260 (values (zig-zag-decode32 val) idx)))
262 (multiple-value-bind (val idx)
263 (decode-uint64 buffer index)
264 (values (zig-zag-decode64 val) idx)))
266 (decode-fixed32 buffer index))
268 (decode-sfixed32 buffer index))
270 (decode-fixed64 buffer index))
272 (decode-sfixed64 buffer index))
274 (multiple-value-bind (val idx)
275 (decode-octets buffer index)
276 (values (babel:octets-to-string val :encoding :utf-8) idx)))
278 (decode-octets buffer index))
280 (multiple-value-bind (val idx)
281 (decode-uint32 buffer index)
282 (values (if (zerop val) nil t) idx)))
284 (decode-single buffer index))
286 (decode-double buffer index))
287 ;; A few of our homegrown types
289 (multiple-value-bind (val idx)
290 (decode-octets buffer index)
291 (let* ((val (babel:octets-to-string val :encoding :utf-8))
292 (colon (position #\: val))
293 (pkg (subseq val 0 colon))
294 (sym (subseq val (i+ colon 1))))
295 (values (intern sym pkg) idx))))
296 ((:date :time :datetime :timestamp)
297 (decode-uint64 buffer index)))))
299 (defun deserialize-packed (type buffer index)
300 "Deserializes the next packed values of type 'type'.
301 Deserializes from the byte vector 'buffer' starting at 'index'.
302 Returns the value and and the new index into the buffer."
303 (declare (type (simple-array (unsigned-byte 8)) buffer)
305 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
306 (multiple-value-bind (len idx)
307 (decode-uint32 buffer index)
308 (declare (type (unsigned-byte 32) len)
310 (let ((end (i+ idx len)))
311 (declare (type (unsigned-byte 32) end))
312 (with-collectors ((values collect-value))
315 (return-from deserialize-packed (values values idx)))
316 (multiple-value-bind (val nidx)
319 (decode-uint32 buffer idx))
321 (decode-uint64 buffer idx))
323 (multiple-value-bind (val idx)
324 (decode-uint32 buffer idx)
325 (values (zig-zag-decode32 val) idx)))
327 (multiple-value-bind (val idx)
328 (decode-uint64 buffer idx)
329 (values (zig-zag-decode64 val) idx)))
331 (decode-fixed32 buffer idx))
333 (decode-sfixed32 buffer idx))
335 (decode-fixed64 buffer idx))
337 (decode-sfixed64 buffer idx))
339 (decode-single buffer idx))
341 (decode-double buffer idx)))
343 (setq idx nidx))))))))
345 (defun deserialize-enum (values buffer index)
346 "Deserializes the next enum value take from 'values'.
347 Deserializes from the byte vector 'buffer' starting at 'index'.
348 Returns the value and and the new index into the buffer."
349 (declare (type (simple-array (unsigned-byte 8)) buffer)
351 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
352 (multiple-value-bind (val idx)
353 (decode-uint32 buffer index)
354 (let ((val (let ((e (find val values :key #'proto-index)))
355 (and e (proto-value e)))))
361 (defun prim-size (val type tag)
362 "Returns the size in bytes that the primitive object will take when serialized."
363 (declare (type (unsigned-byte 32) tag))
364 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
367 (i+ (length32 tag) (length32 val)))
369 (i+ (length32 tag) (length64 val)))
371 (i+ (length32 tag) (length32 (zig-zag-encode32 val))))
373 (i+ (length32 tag) (length64 (zig-zag-encode64 val))))
374 ((:fixed32 :sfixed32)
375 (i+ (length32 tag) 4))
376 ((:fixed64 :sfixed64)
377 (i+ (length32 tag) 8))
379 (let ((len (babel:string-size-in-octets val :encoding :utf-8)))
380 (i+ (length32 tag) (length32 len) len)))
382 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
383 (let ((len (length val)))
384 (i+ (length32 tag) (length32 len) len))))
386 (i+ (length32 tag) 1))
388 (i+ (length32 tag) 4))
390 (i+ (length32 tag) 8))
391 ;; A few of our homegrown types
393 (let* ((len (i+ (length (package-name (symbol-package val))) 1 (length (symbol-name val)))))
394 (i+ (length32 tag) (length32 len) len)))
395 ((:date :time :datetime :timestamp)
396 (i+ (length32 tag) 8)))))
398 (define-compiler-macro prim-size (&whole form val type tag)
401 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
402 (i+ (length32 ,tag) (length32 ,val))))
404 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
405 (i+ (length32 ,tag) (length64 ,val))))
407 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
408 (i+ (length32 ,tag) (length32 (zig-zag-encode32 ,val)))))
410 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
411 (i+ (length32 ,tag) (length64 (zig-zag-encode64 ,val)))))
412 ((:fixed32 :sfixed32)
413 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
414 (i+ (length32 ,tag) 4)))
415 ((:fixed64 :sfixed64)
416 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
417 (i+ (length32 ,tag) 8)))
419 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
420 (let ((len (babel:string-size-in-octets ,val :encoding :utf-8)))
421 (i+ (length32 ,tag) (length32 len) len))))
423 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
424 (let ((len (length ,val)))
425 (i+ (length32 ,tag) (length32 len) len))))
427 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
428 (i+ (length32 ,tag) 1)))
430 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
431 (i+ (length32 ,tag) 4)))
433 `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
434 (i+ (length32 ,tag) 8)))
437 (defun packed-size (values type tag)
438 "Returns the size in bytes that the packed object will take when serialized."
439 (declare (type (unsigned-byte 32) tag))
440 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
441 (let ((len (loop for val in values
443 ((:int32 :uint32) (length32 val))
444 ((:int64 :uint64) (length64 val))
445 ((:sint32) (length32 (zig-zag-encode32 val)))
446 ((:sint64) (length64 (zig-zag-encode64 val)))
447 ((:fixed32 :sfixed32) 4)
448 ((:fixed64 :sfixed64) 8)
451 (declare (type (unsigned-byte 32) tag len))
452 ;; Two value: the full size of the packed object, and the size
453 ;; of just the payload
454 (values (i+ (length32 tag) (length32 len) len) len))))
456 (defun enum-size (val values tag)
457 "Returns the size in bytes that the enum object will take when serialized."
458 (declare (type (unsigned-byte 32) tag))
459 (let ((val (let ((e (find val values :key #'proto-value)))
460 (and e (proto-index e)))))
461 (declare (type (unsigned-byte 32) val))
462 (i+ (length32 tag) (length32 val))))
467 (defun encode-uint32 (val buffer index)
468 "Encodes the unsigned 32-bit integer 'val' as a varint into the buffer
470 Modifies the buffer, and returns the new index into the buffer."
471 (declare (type (unsigned-byte 32) val)
472 (type (simple-array (unsigned-byte 8)) buffer)
474 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
475 ;; Seven bits at a time, least significant bits first
476 (loop do (let ((bits (ldb #.(byte 7 0) val)))
477 (declare (type (unsigned-byte 8) bits))
478 (setq val (ash val -7))
479 (setf (aref buffer index) (ilogior bits (if (zerop val) 0 128)))
482 (values index buffer)) ;return the buffer to improve 'trace'
484 (defun encode-uint64 (val buffer index)
485 "Encodes the unsigned 64-bit integer 'val' as a varint into the buffer
487 Modifies the buffer, and returns the new index into the buffer."
488 (declare (type (unsigned-byte 64) val)
489 (type (simple-array (unsigned-byte 8)) buffer)
491 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
492 (loop do (let ((bits (ldb #.(byte 7 0) val)))
493 (declare (type (unsigned-byte 8) bits))
494 (setq val (ash val -7))
495 (setf (aref buffer index) (ilogior bits (if (zerop val) 0 128)))
498 (values index buffer))
500 (defun encode-fixed32 (val buffer index)
501 "Encodes the unsigned 32-bit integer 'val' as a fixed int into the buffer
503 Modifies the buffer, and returns the new index into the buffer."
504 (declare (type (unsigned-byte 32) val)
505 (type (simple-array (unsigned-byte 8)) buffer)
507 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
509 (let ((byte (ldb #.(byte 8 0) val)))
510 (declare (type (unsigned-byte 8) byte))
511 (setq val (ash val -8))
512 (setf (aref buffer index) byte)
514 (values index buffer))
516 (defun encode-fixed64 (val buffer index)
517 "Encodes the unsigned 64-bit integer 'val' as a fixed int into the buffer
519 Modifies the buffer, and returns the new index into the buffer."
520 (declare (type (unsigned-byte 64) val)
521 (type (simple-array (unsigned-byte 8)) buffer)
523 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
525 (let ((byte (ldb #.(byte 8 0) val)))
526 (declare (type (unsigned-byte 8) byte))
527 (setq val (ash val -8))
528 (setf (aref buffer index) byte)
530 (values index buffer))
532 (defun encode-sfixed32 (val buffer index)
533 "Encodes the signed 32-bit integer 'val' as a fixed int into the buffer
535 Modifies the buffer, and returns the new index into the buffer."
536 (declare (type (signed-byte 32) val)
537 (type (simple-array (unsigned-byte 8)) buffer)
539 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
541 (let ((byte (ldb #.(byte 8 0) val)))
542 (declare (type (unsigned-byte 8) byte))
543 (setq val (ash val -8))
544 (setf (aref buffer index) byte)
546 (values index buffer))
548 (defun encode-sfixed64 (val buffer index)
549 "Encodes the signed 32-bit integer 'val' as a fixed int into the buffer
551 Modifies the buffer, and returns the new index into the buffer."
552 (declare (type (signed-byte 64) val)
553 (type (simple-array (unsigned-byte 8)) buffer)
555 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
557 (let ((byte (ldb #.(byte 8 0) val)))
558 (declare (type (unsigned-byte 8) byte))
559 (setq val (ash val -8))
560 (setf (aref buffer index) byte)
562 (values index buffer))
564 (defun encode-single (val buffer index)
565 "Encodes the single float 'val' into the buffer at the given index.
566 Modifies the buffer, and returns the new index into the buffer."
567 (declare (type single-float val)
568 (type (simple-array (unsigned-byte 8)) buffer)
570 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
571 (let ((bits (single-float-bits val)))
573 (let ((byte (ldb #.(byte 8 0) bits)))
574 (declare (type (unsigned-byte 8) byte))
575 (setq bits (ash bits -8))
576 (setf (aref buffer index) byte)
578 (values index buffer))
580 (defun encode-double (val buffer index)
581 "Encodes the double float 'val' into the buffer at the given index.
582 Modifies the buffer, and returns the new index into the buffer."
583 (declare (type double-float val)
584 (type (simple-array (unsigned-byte 8)) buffer)
586 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
587 (multiple-value-bind (low high)
588 (double-float-bits val)
590 (let ((byte (ldb #.(byte 8 0) low)))
591 (declare (type (unsigned-byte 8) byte))
592 (setq low (ash low -8))
593 (setf (aref buffer index) byte)
596 (let ((byte (ldb #.(byte 8 0) high)))
597 (declare (type (unsigned-byte 8) byte))
598 (setq high (ash high -8))
599 (setf (aref buffer index) byte)
601 (values index buffer))
603 (defun encode-octets (octets buffer index)
604 "Encodes the octets into the buffer at the given index.
605 Modifies the buffer, and returns the new index into the buffer."
606 (declare (type (simple-array (unsigned-byte 8)) buffer)
608 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
609 (let* ((len (length octets))
610 (idx (encode-uint32 len buffer index)))
611 (declare (type fixnum len)
612 (type (unsigned-byte 32) idx))
613 (replace buffer octets :start1 idx)
614 (values (i+ idx len) buffer))))
616 (defun zig-zag-encode32 (val)
617 (declare (type (signed-byte 32) val))
618 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
619 (logxor (ash val 1) (ash val -31))))
621 (defun zig-zag-encode64 (val)
622 (declare (type (signed-byte 64) val))
623 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
624 (logxor (ash val 1) (ash val -63))))
629 ;; Decode the value from the buffer at the given index,
630 ;; then return the value and new index into the buffer
631 (defun decode-uint32 (buffer index)
632 "Decodes the next 32-bit varint integer in the buffer at the given index.
633 Returns both the decoded value and the new index into the buffer."
634 (declare (type (simple-array (unsigned-byte 8)) buffer)
636 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
637 ;; Seven bits at a time, least significant bits first
639 for places fixnum upfrom 0 by 7
640 for byte fixnum = (prog1 (aref buffer index) (iincf index))
641 do (setq val (logior val (ash (ldb #.(byte 7 0) byte) places)))
644 (assert (< val #.(ash 1 32)) ()
645 "The value ~D is longer than 32 bits" val)
646 (return (values val index))))))
648 (defun decode-uint64 (buffer index)
649 "Decodes the next 64-bit varint integer in the buffer at the given index.
650 Returns both the decoded value and the new index into the buffer."
651 (declare (type (simple-array (unsigned-byte 8)) buffer)
653 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
654 ;; Seven bits at a time, least significant bits first
656 for places fixnum upfrom 0 by 7
657 for byte fixnum = (prog1 (aref buffer index) (iincf index))
658 do (setq val (logior val (ash (ldb #.(byte 7 0) byte) places)))
660 finally (return (values val index)))))
662 (defun decode-fixed32 (buffer index)
663 "Decodes the next 32-bit unsigned fixed integer in the buffer at the given index.
664 Returns both the decoded value and the new index into the buffer."
665 (declare (type (simple-array (unsigned-byte 8)) buffer)
667 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
668 ;; Eight bits at a time, least significant bits first
671 for places fixnum upfrom 0 by 8
672 for byte fixnum = (prog1 (aref buffer index) (iincf index))
673 do (setq val (logior val (ash byte places))))
674 (values val index))))
676 (defun decode-sfixed32 (buffer index)
677 "Decodes the next 32-bit signed fixed integer in the buffer at the given index.
678 Returns both the decoded value and the new index into the buffer."
679 (declare (type (simple-array (unsigned-byte 8)) buffer)
681 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
682 ;; Eight bits at a time, least significant bits first
685 for places fixnum upfrom 0 by 8
686 for byte fixnum = (prog1 (aref buffer index) (iincf index))
687 do (setq val (logior val (ash byte places))))
688 (when (i= (ldb #.(byte 1 31) val) 1) ;sign bit set, so negative value
689 (decf val #.(ash 1 32)))
690 (values val index))))
692 (defun decode-fixed64 (buffer index)
693 "Decodes the next unsigned 64-bit fixed integer in the buffer at the given index.
694 Returns both the decoded value and the new index into the buffer."
695 (declare (type (simple-array (unsigned-byte 8)) buffer)
697 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
698 ;; Eight bits at a time, least significant bits first
701 for places fixnum upfrom 0 by 8
702 for byte fixnum = (prog1 (aref buffer index) (iincf index))
703 do (setq val (logior val (ash byte places))))
704 (values val index))))
706 (defun decode-sfixed64 (buffer index)
707 "Decodes the next signed 64-bit fixed integer in the buffer at the given index.
708 Returns both the decoded value and the new index into the buffer."
709 (declare (type (simple-array (unsigned-byte 8)) buffer)
711 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
712 ;; Eight bits at a time, least significant bits first
715 for places fixnum upfrom 0 by 8
716 for byte fixnum = (prog1 (aref buffer index) (iincf index))
717 do (setq val (logior val (ash byte places))))
718 (when (i= (ldb #.(byte 1 63) val) 1) ;sign bit set, so negative value
719 (decf val #.(ash 1 64)))
720 (values val index))))
722 (defun decode-single (buffer index)
723 "Decodes the next single float in the buffer at the given index.
724 Returns both the decoded value and the new index into the buffer."
725 (declare (type (simple-array (unsigned-byte 8)) buffer)
727 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
728 ;; Eight bits at a time, least significant bits first
731 for places fixnum upfrom 0 by 8
732 for byte fixnum = (prog1 (aref buffer index) (iincf index))
733 do (setq bits (logior bits (ash byte places))))
734 (when (i= (ldb #.(byte 1 31) bits) 1) ;sign bit set, so negative value
735 (decf bits #.(ash 1 32)))
736 (values (make-single-float bits) index))))
738 (defun decode-double (buffer index)
739 "Decodes the next double float in the buffer at the given index.
740 Returns both the decoded value and the new index into the buffer."
741 (declare (type (simple-array (unsigned-byte 8)) buffer)
743 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
744 ;; Eight bits at a time, least significant bits first
748 for places fixnum upfrom 0 by 8
749 for byte fixnum = (prog1 (aref buffer index) (iincf index))
750 do (setq low (logior low (ash byte places))))
752 for places fixnum upfrom 0 by 8
753 for byte fixnum = (prog1 (aref buffer index) (iincf index))
754 do (setq high (logior high (ash byte places))))
755 ;; High bits are signed, but low bits are unsigned
756 (when (i= (ldb #.(byte 1 31) high) 1) ;sign bit set, so negative value
757 (decf high #.(ash 1 32)))
758 (values (make-double-float low high) index))))
760 (defun decode-octets (buffer index)
761 "Decodes the next octets in the buffer at the given index.
762 Returns both the decoded value and the new index into the buffer."
763 (declare (type (simple-array (unsigned-byte 8)) buffer)
765 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
766 (multiple-value-bind (len idx)
767 (decode-uint32 buffer index)
768 (declare (type (unsigned-byte 32) len)
770 (values (subseq buffer idx (i+ idx len)) (i+ idx len)))))
772 (defun zig-zag-decode32 (val)
773 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
774 (logxor (ash val -1) (- (logand val 1)))))
776 (defun zig-zag-decode64 (val)
777 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
778 (logxor (ash val -1) (- (logand val 1)))))
783 (defun length32 (val)
784 "Returns the length that 'val' will take when encoded as a 32-bit integer."
785 (assert (< val #.(ash 1 32)) ()
786 "The value ~D is longer than 32 bits" val)
787 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
789 (declare (type fixnum size))
791 (setq val (ash val -7))
796 (defun length64 (val)
797 "Returns the length that 'val' will take when encoded as a 64-bit integer."
798 (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
800 (declare (type fixnum size))
802 (setq val (ash val -7))