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