wire-format.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Confidential and proprietary information of ITA Software, Inc.   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012 ITA Software, Inc.  All rights reserved.      ;;;
   6 ;;;                                                                  ;;;
   7 ;;; Original author: Scott McKay                                     ;;;
   8 ;;;                                                                  ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package "PROTO-IMPL")
  12
  13
  14 ;;; Protocol buffers wire format
  15
  16 ;;; Serializers
  17
  18 ;; Serialize 'val' of primitive type 'type' into the buffer
  19 (defun serialize-prim (val type field buffer index)
  20   "Serializes a Protobufs primitive (scalar) value into the buffer at the given index.
  21    The value is given by 'val', the primitive type by 'type'.
  22    'field' is the protobuf-field describing the value.
  23    Modifies the buffer in place, and returns the new index into the buffer."
  24   (declare (type fixnum index)
  25            (type (simple-array (unsigned-byte 8)) buffer))
  26   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
  27     (ecase type
  28       ((:int32 :uint32)
  29        (let* ((tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
  30               (idx (encode-uint32 tag buffer index)))
  31          (declare (type fixnum tag idx))
  32          (encode-uint32 val buffer idx)))
  33       ((:int64 :uint64)
  34        (let* ((tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
  35               (idx (encode-uint32 tag buffer index)))
  36          (declare (type fixnum tag idx))
  37          (encode-uint64 val buffer idx)))
  38       ((:sint32)
  39        (let* ((tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
  40               (idx (encode-uint32 tag buffer index)))
  41          (declare (type fixnum tag idx))
  42          (encode-uint32 (zig-zag-encode32 val) buffer idx)))
  43       ((:sint64)
  44        (let* ((tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
  45               (idx (encode-uint32 tag buffer index)))
  46          (declare (type fixnum tag idx))
  47          (encode-uint64 (zig-zag-encode64 val) buffer idx)))
  48       ((:fixed32 :sfixed32)
  49        (let* ((tag (ilogior $wire-type-32bit (iash (proto-index field) 3)))
  50               (idx (encode-uint32 tag buffer index)))
  51          (declare (type fixnum tag idx))
  52          (encode-fixed32 val buffer idx)))
  53       ((:fixed64 :sfixed64)
  54        (let* ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3)))
  55               (idx (encode-uint32 tag buffer index)))
  56          (declare (type fixnum tag idx))
  57          (encode-fixed64 val buffer idx)))
  58       ((:string)
  59        (let* ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
  60               (idx (encode-uint32 tag buffer index)))
  61                (declare (type fixnum tag idx))
  62          (encode-octets (babel:string-to-octets val :encoding :utf-8) buffer idx)))
  63       ((:bytes)
  64        (let* ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
  65               (idx (encode-uint32 tag buffer index)))
  66          (declare (type fixnum tag idx))
  67          (encode-octets val buffer idx)))
  68       ((:bool)
  69        (let* ((tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
  70               (idx (encode-uint32 tag buffer index)))
  71          (declare (type fixnum tag idx))
  72          (encode-uint32 (if val 1 0) buffer idx)))
  73       ((:float)
  74        (let* ((tag (ilogior $wire-type-32bit (iash (proto-index field) 3)))
  75               (idx (encode-uint32 tag buffer index)))
  76          (declare (type fixnum tag idx))
  77          (encode-single val buffer idx)))
  78       ((:double)
  79        (let* ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3)))
  80               (idx (encode-uint32 tag buffer index)))
  81          (declare (type fixnum tag idx))
  82          (encode-double val buffer idx)))
  83       ;; A few of our homegrown types
  84       ((:symbol)
  85        (let* ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
  86               (idx (encode-uint32 tag buffer index))
  87               (val (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val))))
  88          ;; Call 'string' in case we are trying to serialize a symbol name
  89          (declare (type fixnum tag idx))
  90          (encode-octets (babel:string-to-octets val :encoding :utf-8) buffer idx)))
  91       ((:date :time :datetime :timestamp)
  92        (let* ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3)))
  93               (idx (encode-uint32 tag buffer index)))
  94          (declare (type fixnum tag idx))
  95          (encode-uint64 val buffer idx))))))
  96
  97 (defun serialize-packed (values type field buffer index)
  98   "Serializes a set of packed values into the buffer at the given index.
  99    The values are given by 'values', the primitive type by 'type'.
 100    'field' is the protobuf-field describing the value.
 101    Modifies the buffer in place, and returns the new index into the buffer."
 102   (declare (type fixnum index)
 103            (type (simple-array (unsigned-byte 8)) buffer))
 104   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 105     (let* ((wtype (ecase type
 106                     ((:int32 :int64)   $wire-type-varint)
 107                     ((:uint32 :uint64) $wire-type-varint)
 108                     ((:sint32 :sint64) $wire-type-varint)
 109                     ((:fixed32 :sfixed32) $wire-type-32bit)
 110                     ((:fixed64 :sfixed64) $wire-type-64bit)
 111                     ((:float)  $wire-type-32bit)
 112                     ((:double) $wire-type-64bit)))
 113            (tag (ilogior wtype (iash (proto-index field) 3)))
 114            (idx (encode-uint32 tag buffer index)))
 115       (declare (type fixnum wtype tag idx))
 116       (multiple-value-bind (full-len len)
 117           (packed-size values type field)
 118         (declare (type fixnum len) (ignore full-len))
 119         (setq idx (encode-uint32 len buffer idx)))
 120       (ecase type
 121         ((:int32 :uint32)
 122          (dolist (val values idx)
 123            (setq idx (encode-uint32 val buffer idx))))
 124         ((:int64 :uint64)
 125          (dolist (val values idx)
 126            (setq idx (encode-uint64 val buffer idx))))
 127         ((:sint32)
 128          (dolist (val values idx)
 129            (setq idx (encode-uint32 (zig-zag-encode32 val) buffer idx))))
 130         ((:sint64)
 131          (dolist (val values idx)
 132            (setq idx (encode-uint64 (zig-zag-encode64 val) buffer idx))))
 133         ((:fixed32 :sfixed32)
 134          (dolist (val values idx)
 135            (setq idx (encode-fixed32 val buffer idx))))
 136         ((:fixed64 :sfixed64)
 137          (dolist (val values idx)
 138            (setq idx (encode-fixed64 val buffer idx))))
 139         ((:float)
 140          (dolist (val values idx)
 141            (setq idx (encode-single val buffer idx))))
 142         ((:double)
 143          (dolist (val values idx)
 144            (setq idx (encode-double val buffer idx))))))))
 145
 146 ;; Serialize 'val' of enum type 'type' into the buffer
 147 (defun serialize-enum (val enum field buffer index)
 148   "Serializes a Protobufs enum value into the buffer at the given index.
 149    The value is given by 'val', the enum type by 'enum'.
 150    'field' is the protobuf-field describing the value.
 151    Modifies the buffer in place, and returns the new index into the buffer."
 152   (declare (type fixnum index)
 153            (type (simple-array (unsigned-byte 8)) buffer))
 154   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 155     (let* ((val (let ((e (find val (proto-values enum) :key #'proto-value)))
 156                   (and e (proto-index e))))
 157            (tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
 158            (idx (encode-uint32 tag buffer index)))
 159       (declare (type fixnum val tag idx))
 160       (encode-uint32 val buffer idx))))
 161
 162
 163 ;;; Deserializers
 164
 165 ;; Deserialize the next object of type 'type', described by the protobuf field 'field'
 166 (defun deserialize-prim (type field buffer index)
 167   "Deserializes the next object of primitive type 'type', described by the protobuf-field 'field'.
 168    Deserializes from the byte vector 'buffer' starting at 'index'.
 169    Returns the value and and the new index into the buffer."
 170   (declare (type fixnum index)
 171            (type (simple-array (unsigned-byte 8)) buffer))
 172   (declare (ignore field))
 173   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 174     (ecase type
 175       ((:int32 :uint32)
 176        (decode-uint32 buffer index))
 177       ((:int64 :uint64)
 178        (decode-uint64 buffer index))
 179       ((:sint32)
 180        (multiple-value-bind (val idx)
 181            (decode-uint32 buffer index)
 182          (values (zig-zag-decode32 val) idx)))
 183       ((:sint64)
 184        (multiple-value-bind (val idx)
 185            (decode-uint64 buffer index)
 186          (values (zig-zag-decode64 val) idx)))
 187       ((:fixed32 :sfixed32)
 188        (decode-fixed32 buffer index))
 189       ((:fixed64 :sfixed64)
 190        (decode-fixed64 buffer index))
 191       ((:string)
 192        (multiple-value-bind (val idx)
 193            (decode-octets buffer index)
 194          (values (babel:octets-to-string val :encoding :utf-8) idx)))
 195       ((:bytes)
 196        (decode-octets buffer index))
 197       ((:bool)
 198        (multiple-value-bind (val idx)
 199            (decode-uint32 buffer index)
 200          (values (if (zerop val) nil t) idx)))
 201       ((:float)
 202        (decode-single buffer index))
 203       ((:double)
 204        (decode-double buffer index))
 205       ;; A few of our homegrown types
 206       ((:symbol)
 207        (multiple-value-bind (val idx)
 208            (decode-octets buffer index)
 209          (let* ((val   (babel:octets-to-string val :encoding :utf-8))
 210                 (colon (position #\: val))
 211                 (pkg   (subseq val 0 colon))
 212                 (sym   (subseq val (i+ colon 1))))
 213            (values (intern sym pkg) idx))))
 214       ((:date :time :datetime :timestamp)
 215        (decode-uint64 buffer index)))))
 216
 217 (defun deserialize-packed (type field buffer index)
 218   "Deserializes the next packed values of type 'type', described by the protobuf-field 'field'.
 219    Deserializes from the byte vector 'buffer' starting at 'index'.
 220    Returns the value and and the new index into the buffer."
 221   (declare (type fixnum index)
 222            (type (simple-array (unsigned-byte 8)) buffer))
 223   (declare (ignore field))
 224   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 225     (multiple-value-bind (len idx)
 226         (decode-uint32 buffer index)
 227       (declare (type fixnum len idx))
 228       (let ((end (i+ idx len)))
 229         (declare (type fixnum end))
 230         (with-collectors ((values collect-value))
 231           (loop
 232             (when (>= idx end)
 233               (return-from deserialize-packed (values values idx)))
 234             (multiple-value-bind (val nidx)
 235                 (ecase type
 236                   ((:int32 :uint32)
 237                    (decode-uint32 buffer idx))
 238                   ((:int64 :uint64)
 239                    (decode-uint64 buffer idx))
 240                   ((:sint32)
 241                    (multiple-value-bind (val idx)
 242                        (decode-uint32 buffer idx)
 243                      (values (zig-zag-decode32 val) idx)))
 244                   ((:sint64)
 245                    (multiple-value-bind (val idx)
 246                        (decode-uint64 buffer idx)
 247                      (values (zig-zag-decode64 val) idx)))
 248                   ((:fixed32 :sfixed32)
 249                    (decode-fixed32 buffer idx))
 250                   ((:fixed64 :sfixed64)
 251                    (decode-fixed64 buffer idx))
 252                   ((:float)
 253                    (decode-single buffer idx))
 254                   ((:double)
 255                    (decode-double buffer idx)))
 256               (collect-value val)
 257               (setq idx nidx))))))))
 258
 259 (defun deserialize-enum (enum field buffer index)
 260   "Deserializes the next enum of type 'type', described by the protobuf-field 'field'.
 261    Deserializes from the byte vector 'buffer' starting at 'index'.
 262    Returns the value and and the new index into the buffer."
 263   (declare (type fixnum index)
 264            (type (simple-array (unsigned-byte 8)) buffer))
 265   (declare (ignore field))
 266   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 267     (multiple-value-bind (val idx)
 268         (decode-uint32 buffer index)
 269       (let ((val (let ((e (find val (proto-values enum) :key #'proto-index)))
 270                    (and e (proto-value e)))))
 271         (values val idx)))))
 272
 273
 274 ;;; Object sizing
 275
 276 (defun prim-size (val type field)
 277   "Returns the size in bytes that the primitive object will take when serialized."
 278   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 279     (ecase type
 280       ((:int32 :uint32)
 281        (let ((tag (ilogior $wire-type-varint (iash (proto-index field) 3))))
 282          (i+ (length32 tag) (length32 val))))
 283       ((:int64 :uint64)
 284        (let ((tag (ilogior $wire-type-varint (iash (proto-index field) 3))))
 285          (i+ (length32 tag) (length64 val))))
 286       ((:sint32)
 287        (let ((tag (ilogior $wire-type-varint (iash (proto-index field) 3))))
 288          (i+ (length32 tag) (length32 (zig-zag-encode32 val)))))
 289       ((:sint64)
 290        (let ((tag (ilogior $wire-type-varint (iash (proto-index field) 3))))
 291          (i+ (length32 tag) (length64 (zig-zag-encode64 val)))))
 292       ((:fixed32 :sfixed32)
 293        (let ((tag (ilogior $wire-type-32bit (iash (proto-index field) 3))))
 294          (i+ (length32 tag) 4)))
 295       ((:fixed64 :sfixed64)
 296        (let ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3))))
 297          (i+ (length32 tag) 8)))
 298       ((:string)
 299        (let ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
 300              (len (babel:string-size-in-octets val :encoding :utf-8)))
 301          (i+ (length32 tag) (length32 len) len)))
 302       ((:bytes)
 303        (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 304          (let ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
 305                (len (length val)))
 306            (i+ (length32 tag) (length32 len) len))))
 307       ((:bool)
 308        (let ((tag (ilogior $wire-type-varint (iash (proto-index field) 3))))
 309          (i+ (length32 tag) 1)))
 310       ((:float)
 311        (let ((tag (ilogior $wire-type-32bit (iash (proto-index field) 3))))
 312          (i+ (length32 tag) 4)))
 313       ((:double)
 314        (let ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3))))
 315          (i+ (length32 tag) 8)))
 316       ;; A few of our homegrown types
 317       ((:symbol)
 318        (let* ((tag (ilogior $wire-type-string (iash (proto-index field) 3)))
 319               (len (i+ (length (package-name (symbol-package val))) 1 (length (symbol-name val)))))
 320          (i+ (length32 tag) (length32 len) len)))
 321       ((:date :time :datetime :timestamp)
 322        (let ((tag (ilogior $wire-type-64bit (iash (proto-index field) 3))))
 323          (i+ (length32 tag) 8))))))
 324
 325 (defun packed-size (values type field)
 326   "Returns the size in bytes that the packed object will take when serialized."
 327   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 328     (let ((tag (ilogior $wire-type-varint (iash (proto-index field) 3)))
 329           (len (loop for val in values
 330                      summing (ecase type
 331                                ((:int32 :uint32) (length32 val))
 332                                ((:int64 :uint64) (length64 val))
 333                                ((:sint32) (length32 (zig-zag-encode32 val)))
 334                                ((:sint64) (length64 (zig-zag-encode64 val)))
 335                                ((:fixed32 :sfixed32) 4)
 336                                ((:fixed64 :sfixed64) 8)
 337                                ((:float) 4)
 338                                ((:double) 8)))))
 339       (declare (type fixnum tag len))
 340       ;; Two value: the full size of the packed object, and the size
 341       ;; of just the payload
 342       (values (i+ (length32 tag) (length32 len) len) len))))
 343
 344 (defun enum-size (val enum field)
 345   "Returns the size in bytes that the enum object will take when serialized."
 346   (let ((val (let ((e (find val (proto-values enum) :key #'proto-value)))
 347                (and e (proto-index e))))
 348         (tag (ilogior $wire-type-varint (iash (proto-index field) 3))))
 349     (i+ (length32 tag) (length32 val))))
 350
 351
 352 ;;; Raw encoders
 353
 354 (defun encode-uint32 (val buffer index)
 355   "Encodes the 32-bit integer 'val' as a varint into the buffer at the given index.
 356    Modifies the buffer, and returns the new index into the buffer."
 357   (declare (type fixnum index)
 358            (type (simple-array (unsigned-byte 8)) buffer))
 359   (assert (< val #.(ash 1 32)) ()
 360           "The value ~D is longer than 32 bits" val)
 361   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 362     ;; Seven bits at a time, least significant bits first
 363     (loop do (let ((bits (ldb #.(byte 7 0) val)))
 364                (declare (type fixnum bits))
 365                (setq val (ash val -7))
 366                (setf (aref buffer index) (ilogior bits (if (zerop val) 0 128)))
 367                (iincf index))
 368           until (zerop val)))
 369   (values index buffer))                        ;return the buffer to improve 'trace'
 370
 371 (defun encode-uint64 (val buffer index)
 372   "Encodes the 64-bit integer 'val' as a varint into the buffer at the given index.
 373    Modifies the buffer, and returns the new index into the buffer."
 374   (declare (type fixnum index)
 375            (type (simple-array (unsigned-byte 8)) buffer))
 376   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 377     (loop do (let ((bits (ldb #.(byte 7 0) val)))
 378                (declare (type fixnum bits))
 379                (setq val (ash val -7))
 380                (setf (aref buffer index) (ilogior bits (if (zerop val) 0 128)))
 381                (iincf index))
 382           until (zerop val)))
 383   (values index buffer))
 384
 385 (defun encode-fixed32 (val buffer index)
 386   "Encodes the 32-bit integer 'val' as a fixed int into the buffer at the given index.
 387    Modifies the buffer, and returns the new index into the buffer."
 388   (declare (type fixnum index)
 389            (type (simple-array (unsigned-byte 8)) buffer))
 390   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 391     (loop repeat 4 doing
 392       (let ((byte (ldb #.(byte 8 0) val)))
 393         (declare (type fixnum byte))
 394         (setq val (ash val -8))
 395         (setf (aref buffer index) byte)
 396         (iincf index))))
 397   (values index buffer))
 398
 399 (defun encode-fixed64 (val buffer index)
 400   "Encodes the 64-bit integer 'val' as a fixed int into the buffer at the given index.
 401    Modifies the buffer, and returns the new index into the buffer."
 402   (declare (type fixnum index)
 403            (type (simple-array (unsigned-byte 8)) buffer))
 404   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 405     (loop repeat 8 doing
 406       (let ((byte (ldb #.(byte 8 0) val)))
 407         (declare (type fixnum byte))
 408         (setq val (ash val -8))
 409         (setf (aref buffer index) byte)
 410         (iincf index))))
 411   (values index buffer))
 412
 413 (defun encode-single (val buffer index)
 414   "Encodes the single float 'val' into the buffer at the given index.
 415    Modifies the buffer, and returns the new index into the buffer."
 416   (declare (type fixnum index)
 417            (type (simple-array (unsigned-byte 8)) buffer))
 418   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 419     (let ((bits (single-float-bits val)))
 420       (loop repeat 4 doing
 421         (let ((byte (ldb #.(byte 8 0) bits)))
 422           (declare (type fixnum byte))
 423           (setq bits (ash bits -8))
 424           (setf (aref buffer index) byte)
 425           (iincf index)))))
 426   (values index buffer))
 427
 428 (defun encode-double (val buffer index)
 429   "Encodes the double float 'val' into the buffer at the given index.
 430    Modifies the buffer, and returns the new index into the buffer."
 431   (declare (type fixnum index)
 432            (type (simple-array (unsigned-byte 8)) buffer))
 433   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 434     (multiple-value-bind (low high)
 435         (double-float-bits val)
 436       (loop repeat 4 doing
 437         (let ((byte (ldb #.(byte 8 0) low)))
 438           (declare (type fixnum byte))
 439           (setq low (ash low -8))
 440           (setf (aref buffer index) byte)
 441           (iincf index)))
 442       (loop repeat 4 doing
 443         (let ((byte (ldb #.(byte 8 0) high)))
 444           (declare (type fixnum byte))
 445           (setq high (ash high -8))
 446           (setf (aref buffer index) byte)
 447           (iincf index)))))
 448   (values index buffer))
 449
 450 (defun encode-octets (octets buffer index)
 451   "Encodes the octets into the buffer at the given index.
 452    Modifies the buffer, and returns the new index into the buffer."
 453   (declare (type fixnum index)
 454            (type (simple-array (unsigned-byte 8)) buffer))
 455   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 456     (let* ((len (length octets))
 457            (idx (encode-uint32 len buffer index)))
 458       (declare (type fixnum len idx))
 459       (replace buffer octets :start1 idx)
 460       (values (i+ idx len) buffer))))
 461
 462 (defun zig-zag-encode32 (val)
 463   (assert (< (integer-length val) 32))
 464   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 465     (logxor (ash val 1) (ash val -31))))
 466
 467 (defun zig-zag-encode64 (val)
 468   (assert (< (integer-length val) 64))
 469   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 470     (logxor (ash val 1) (ash val -63))))
 471
 472
 473 ;;; Raw decoders
 474
 475 ;; Decode the value from the buffer at the given index,
 476 ;; then return the value and new index into the buffer
 477 (defun decode-uint32 (buffer index)
 478   "Decodes the next 32-bit varint integer in the buffer at the given index.
 479    Returns both the decoded value and the new index into the buffer."
 480   (declare (type fixnum index)
 481            (type (simple-array (unsigned-byte 8)) buffer))
 482   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 483     ;; Seven bits at a time, least significant bits first
 484     (loop with val = 0
 485           for places fixnum upfrom 0 by 7
 486           for byte fixnum = (prog1 (aref buffer index) (iincf index))
 487           do (setq val (logior val (ash (ldb #.(byte 7 0) byte) places)))
 488           until (i< byte 128)
 489           finally (progn
 490                     (assert (< val #.(ash 1 32)) ()
 491                             "The value ~D is longer than 32 bits" val)
 492                     (return (values val index))))))
 493
 494 (defun decode-uint64 (buffer index)
 495   "Decodes the next 64-bit varint integer in the buffer at the given index.
 496    Returns both the decoded value and the new index into the buffer."
 497   (declare (type fixnum index)
 498            (type (simple-array (unsigned-byte 8)) buffer))
 499   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 500     ;; Seven bits at a time, least significant bits first
 501     (loop with val = 0
 502           for places fixnum upfrom 0 by 7
 503           for byte fixnum = (prog1 (aref buffer index) (iincf index))
 504           do (setq val (logior val (ash (ldb #.(byte 7 0) byte) places)))
 505           until (i< byte 128)
 506           finally (return (values val index)))))
 507
 508 (defun decode-fixed32 (buffer index)
 509   "Decodes the next 32-bit fixed integer in the buffer at the given index.
 510    Returns both the decoded value and the new index into the buffer."
 511   (declare (type fixnum index)
 512            (type (simple-array (unsigned-byte 8)) buffer))
 513   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 514     ;; Eight bits at a time, least significant bits first
 515     (let ((bits 0))
 516       (loop repeat 4
 517             for places fixnum upfrom 0 by 8
 518             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 519             do (setq bits (logior bits (ash byte places))))
 520       (when (i= (ldb #.(byte 1 31) bits) 1)             ;sign bit set, so negative value
 521         (decf bits #.(ash 1 32)))
 522       (values bits index))))
 523
 524 (defun decode-fixed64 (buffer index)
 525   "Decodes the next 64-bit fixed integer in the buffer at the given index.
 526    Returns both the decoded value and the new index into the buffer."
 527   (declare (type fixnum index)
 528            (type (simple-array (unsigned-byte 8)) buffer))
 529   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 530     ;; Eight bits at a time, least significant bits first
 531     (let ((bits 0))
 532       (loop repeat 8
 533             for places fixnum upfrom 0 by 8
 534             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 535             do (setq bits (logior bits (ash byte places))))
 536       (when (i= (ldb #.(byte 1 63) bits) 1)             ;sign bit set, so negative value
 537         (decf bits #.(ash 1 64)))
 538       (values bits index))))
 539
 540 (defun decode-single (buffer index)
 541   "Decodes the next single float in the buffer at the given index.
 542    Returns both the decoded value and the new index into the buffer."
 543   (declare (type fixnum index)
 544            (type (simple-array (unsigned-byte 8)) buffer))
 545   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 546     ;; Eight bits at a time, least significant bits first
 547     (let ((bits 0))
 548       (loop repeat 4
 549             for places fixnum upfrom 0 by 8
 550             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 551             do (setq bits (logior bits (ash byte places))))
 552       (when (i= (ldb #.(byte 1 31) bits) 1)             ;sign bit set, so negative value
 553         (decf bits #.(ash 1 32)))
 554       (values (make-single-float bits) index))))
 555
 556 (defun decode-double (buffer index)
 557   "Decodes the next double float in the buffer at the given index.
 558    Returns both the decoded value and the new index into the buffer."
 559   (declare (type fixnum index)
 560            (type (simple-array (unsigned-byte 8)) buffer))
 561   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 562     ;; Eight bits at a time, least significant bits first
 563     (let ((low  0)
 564           (high 0))
 565       (loop repeat 4
 566             for places fixnum upfrom 0 by 8
 567             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 568             do (setq low (logior low (ash byte places))))
 569       (loop repeat 4
 570             for places fixnum upfrom 0 by 8
 571             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 572             do (setq high (logior high (ash byte places))))
 573       ;; High bits are signed, but low bits are unsigned
 574       (when (i= (ldb #.(byte 1 31) high) 1)             ;sign bit set, so negative value
 575         (decf high #.(ash 1 32)))
 576       (values (make-double-float low high) index))))
 577
 578 (defun decode-octets (buffer index)
 579   "Decodes the next octets in the buffer at the given index.
 580    Returns both the decoded value and the new index into the buffer."
 581   (declare (type fixnum index)
 582            (type (simple-array (unsigned-byte 8)) buffer))
 583   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 584     (multiple-value-bind (len idx)
 585         (decode-uint32 buffer index)
 586       (declare (type fixnum len idx))
 587       (values (subseq buffer idx (i+ idx len)) (i+ idx len)))))
 588
 589 (defun zig-zag-decode32 (val)
 590   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 591     (logxor (ash val -1) (- (logand val 1)))))
 592
 593 (defun zig-zag-decode64 (val)
 594   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 595     (logxor (ash val -1) (- (logand val 1)))))
 596
 597
 598 ;;; Raw lengths
 599
 600 (defun length32 (val)
 601   "Returns the length that 'val' will take when encoded as a 32-bit integer."
 602   (assert (< val #.(ash 1 32)) ()
 603           "The value ~D is longer than 32 bits" val)
 604   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 605     (let ((size 0))
 606       (declare (type fixnum size))
 607       (loop do (progn
 608                  (setq val (ash val -7))
 609                  (iincf size))
 610             until (zerop val))
 611       size)))
 612
 613 (defun length64 (val)
 614   "Returns the length that 'val' will take when encoded as a 64-bit integer."
 615   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 616     (let ((size 0))
 617       (declare (type fixnum size))
 618       (loop do (progn
 619                  (setq val (ash val -7))
 620                  (iincf size))
 621             until (zerop val))
 622       size)))