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 ;;; Utilities
  17
  18 (defconstant $wire-type-varint 0)
  19 (defconstant $wire-type-64bit  1)
  20 (defconstant $wire-type-string 2)
  21 (defconstant $wire-type-32bit  5)
  22
  23 (defun make-tag (type index)
  24   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
  25     (if (typep type 'fixnum)
  26       type
  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))))))
  41
  42 (define-compiler-macro make-tag (&whole form type index)
  43   (cond ((typep type 'fixnum)
  44          `(ilogior ,type (iash ,index 3)))
  45         ((keywordp type)
  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))))
  60         (t form)))
  61
  62
  63 ;;; Serializers
  64
  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)
  72            (type fixnum index))
  73   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
  74     (let ((idx (encode-uint32 tag buffer index)))
  75       (declare (type fixnum idx))
  76       (ecase type
  77         ((:int32 :uint32)
  78          (encode-uint32 val buffer idx))
  79         ((:int64 :uint64)
  80          (encode-uint64 val buffer idx))
  81         ((:sint32)
  82          (encode-uint32 (zig-zag-encode32 val) buffer idx))
  83         ((:sint64)
  84          (encode-uint64 (zig-zag-encode64 val) buffer idx))
  85         ((:fixed32)
  86          (encode-fixed32 val buffer idx))
  87         ((:sfixed32)
  88          (encode-sfixed32 val buffer idx))
  89         ((:fixed64)
  90          (encode-fixed64 val buffer idx))
  91         ((:sfixed64)
  92          (encode-sfixed64 val buffer idx))
  93         ((:string)
  94          (encode-octets (babel:string-to-octets val :encoding :utf-8) buffer idx))
  95         ((:bytes)
  96          (encode-octets val buffer idx))
  97         ((:bool)
  98          (encode-uint32 (if val 1 0) buffer idx))
  99         ((:float)
 100          (encode-single val buffer idx))
 101         ((:double)
 102          (encode-double val buffer idx))
 103         ;; A few of our homegrown types
 104         ((:symbol)
 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))))))
 110
 111 (define-compiler-macro serialize-prim (&whole form val type tag buffer index)
 112   (case type
 113     ((:int32 :uint32)
 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))))
 118     ((:int64 :uint64)
 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))))
 123    ((:sint32)
 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))))
 128    ((:sint64)
 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))))
 133    ((:fixed32)
 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))))
 138    ((:sfixed32)
 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))))
 143    ((:fixed64)
 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))))
 148    ((:sfixed64)
 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))))
 153    ((:string)
 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))))
 158    ((:bytes)
 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))))
 163    ((:bool)
 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))))
 168    ((:float)
 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))))
 173    ((:double)
 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))))
 178    (otherwise form)))
 179
 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)
 186            (type fixnum index))
 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)))
 194       (ecase type
 195         ((:int32 :uint32)
 196          (dolist (val values idx)
 197            (setq idx (encode-uint32 val buffer idx))))
 198         ((:int64 :uint64)
 199          (dolist (val values idx)
 200            (setq idx (encode-uint64 val buffer idx))))
 201         ((:sint32)
 202          (dolist (val values idx)
 203            (setq idx (encode-uint32 (zig-zag-encode32 val) buffer idx))))
 204         ((:sint64)
 205          (dolist (val values idx)
 206            (setq idx (encode-uint64 (zig-zag-encode64 val) buffer idx))))
 207         ((:fixed32)
 208          (dolist (val values idx)
 209            (setq idx (encode-fixed32 val buffer idx))))
 210         ((:sfixed32)
 211          (dolist (val values idx)
 212            (setq idx (encode-sfixed32 val buffer idx))))
 213         ((:fixed64)
 214          (dolist (val values idx)
 215            (setq idx (encode-fixed64 val buffer idx))))
 216         ((:sfixed64)
 217          (dolist (val values idx)
 218            (setq idx (encode-sfixed64 val buffer idx))))
 219         ((:float)
 220          (dolist (val values idx)
 221            (setq idx (encode-single val buffer idx))))
 222         ((:double)
 223          (dolist (val values idx)
 224            (setq idx (encode-double val buffer idx))))))))
 225
 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)
 232            (type fixnum index))
 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)
 238                (type fixnum idx))
 239       (encode-uint32 val buffer idx))))
 240
 241
 242 ;;; Deserializers
 243
 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)
 250            (type fixnum index))
 251   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 252     (ecase type
 253       ((:int32 :uint32)
 254        (decode-uint32 buffer index))
 255       ((:int64 :uint64)
 256        (decode-uint64 buffer index))
 257       ((:sint32)
 258        (multiple-value-bind (val idx)
 259            (decode-uint32 buffer index)
 260          (values (zig-zag-decode32 val) idx)))
 261       ((:sint64)
 262        (multiple-value-bind (val idx)
 263            (decode-uint64 buffer index)
 264          (values (zig-zag-decode64 val) idx)))
 265       ((:fixed32)
 266        (decode-fixed32 buffer index))
 267       ((:sfixed32)
 268        (decode-sfixed32 buffer index))
 269       ((:fixed64)
 270        (decode-fixed64 buffer index))
 271       ((:sfixed64)
 272        (decode-sfixed64 buffer index))
 273       ((:string)
 274        (multiple-value-bind (val idx)
 275            (decode-octets buffer index)
 276          (values (babel:octets-to-string val :encoding :utf-8) idx)))
 277       ((:bytes)
 278        (decode-octets buffer index))
 279       ((:bool)
 280        (multiple-value-bind (val idx)
 281            (decode-uint32 buffer index)
 282          (values (if (zerop val) nil t) idx)))
 283       ((:float)
 284        (decode-single buffer index))
 285       ((:double)
 286        (decode-double buffer index))
 287       ;; A few of our homegrown types
 288       ((:symbol)
 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)))))
 298
 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)
 304            (type fixnum index))
 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)
 309                (type fixnum idx))
 310       (let ((end (i+ idx len)))
 311         (declare (type (unsigned-byte 32) end))
 312         (with-collectors ((values collect-value))
 313           (loop
 314             (when (>= idx end)
 315               (return-from deserialize-packed (values values idx)))
 316             (multiple-value-bind (val nidx)
 317                 (ecase type
 318                   ((:int32 :uint32)
 319                    (decode-uint32 buffer idx))
 320                   ((:int64 :uint64)
 321                    (decode-uint64 buffer idx))
 322                   ((:sint32)
 323                    (multiple-value-bind (val idx)
 324                        (decode-uint32 buffer idx)
 325                      (values (zig-zag-decode32 val) idx)))
 326                   ((:sint64)
 327                    (multiple-value-bind (val idx)
 328                        (decode-uint64 buffer idx)
 329                      (values (zig-zag-decode64 val) idx)))
 330                   ((:fixed32)
 331                    (decode-fixed32 buffer idx))
 332                   ((:sfixed32)
 333                    (decode-sfixed32 buffer idx))
 334                   ((:fixed64)
 335                    (decode-fixed64 buffer idx))
 336                   ((:sfixed64)
 337                    (decode-sfixed64 buffer idx))
 338                   ((:float)
 339                    (decode-single buffer idx))
 340                   ((:double)
 341                    (decode-double buffer idx)))
 342               (collect-value val)
 343               (setq idx nidx))))))))
 344
 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)
 350            (type fixnum index))
 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)))))
 356         (values val idx)))))
 357
 358
 359 ;;; Object sizing
 360
 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)))
 365     (ecase type
 366       ((:int32 :uint32)
 367        (i+ (length32 tag) (length32 val)))
 368       ((:int64 :uint64)
 369        (i+ (length32 tag) (length64 val)))
 370       ((:sint32)
 371        (i+ (length32 tag) (length32 (zig-zag-encode32 val))))
 372       ((:sint64)
 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))
 378       ((:string)
 379        (let ((len (babel:string-size-in-octets val :encoding :utf-8)))
 380          (i+ (length32 tag) (length32 len) len)))
 381       ((:bytes)
 382        (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 383          (let ((len (length val)))
 384            (i+ (length32 tag) (length32 len) len))))
 385       ((:bool)
 386        (i+ (length32 tag) 1))
 387       ((:float)
 388        (i+ (length32 tag) 4))
 389       ((:double)
 390        (i+ (length32 tag) 8))
 391       ;; A few of our homegrown types
 392       ((:symbol)
 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)))))
 397
 398 (define-compiler-macro prim-size (&whole form val type tag)
 399   (case type
 400     ((:int32 :uint32)
 401      `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 402         (i+ (length32 ,tag) (length32 ,val))))
 403     ((:int64 :uint64)
 404      `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 405         (i+ (length32 ,tag) (length64 ,val))))
 406     ((:sint32)
 407      `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 408         (i+ (length32 ,tag) (length32 (zig-zag-encode32 ,val)))))
 409     ((:sint64)
 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)))
 418     ((:string)
 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))))
 422     ((:bytes)
 423      `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 424         (let ((len (length ,val)))
 425           (i+ (length32 ,tag) (length32 len) len))))
 426     ((:bool)
 427      `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 428         (i+ (length32 ,tag) 1)))
 429     ((:float)
 430      `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 431         (i+ (length32 ,tag) 4)))
 432     ((:double)
 433      `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 434         (i+ (length32 ,tag) 8)))
 435     (otherwise form)))
 436
 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
 442                      summing (ecase type
 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)
 449                                ((:float) 4)
 450                                ((:double) 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))))
 455
 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))))
 463
 464
 465 ;;; Raw encoders
 466
 467 (defun encode-uint32 (val buffer index)
 468   "Encodes the unsigned 32-bit integer 'val' as a varint into the buffer
 469    at the given index.
 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)
 473            (type fixnum index))
 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)))
 480                (iincf index))
 481           until (zerop val)))
 482   (values index buffer))                        ;return the buffer to improve 'trace'
 483
 484 (defun encode-uint64 (val buffer index)
 485   "Encodes the unsigned 64-bit integer 'val' as a varint into the buffer
 486    at the given index.
 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)
 490            (type fixnum index))
 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)))
 496                (iincf index))
 497           until (zerop val)))
 498   (values index buffer))
 499
 500 (defun encode-fixed32 (val buffer index)
 501   "Encodes the unsigned 32-bit integer 'val' as a fixed int into the buffer
 502    at the given index.
 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)
 506            (type fixnum index))
 507   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 508     (loop repeat 4 doing
 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)
 513         (iincf index))))
 514   (values index buffer))
 515
 516 (defun encode-fixed64 (val buffer index)
 517   "Encodes the unsigned 64-bit integer 'val' as a fixed int into the buffer
 518    at the given index.
 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)
 522            (type fixnum index))
 523   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 524     (loop repeat 8 doing
 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)
 529         (iincf index))))
 530   (values index buffer))
 531
 532 (defun encode-sfixed32 (val buffer index)
 533   "Encodes the signed 32-bit integer 'val' as a fixed int into the buffer
 534    at the given index.
 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)
 538            (type fixnum index))
 539   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 540     (loop repeat 4 doing
 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)
 545         (iincf index))))
 546   (values index buffer))
 547
 548 (defun encode-sfixed64 (val buffer index)
 549   "Encodes the signed 32-bit integer 'val' as a fixed int into the buffer
 550    at the given index.
 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)
 554            (type fixnum index))
 555   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 556     (loop repeat 8 doing
 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)
 561         (iincf index))))
 562   (values index buffer))
 563
 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)
 569            (type fixnum index))
 570   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 571     (let ((bits (single-float-bits val)))
 572       (loop repeat 4 doing
 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)
 577           (iincf index)))))
 578   (values index buffer))
 579
 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)
 585            (type fixnum index))
 586   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 587     (multiple-value-bind (low high)
 588         (double-float-bits val)
 589       (loop repeat 4 doing
 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)
 594           (iincf index)))
 595       (loop repeat 4 doing
 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)
 600           (iincf index)))))
 601   (values index buffer))
 602
 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)
 607            (type fixnum index))
 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))))
 615
 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))))
 620
 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))))
 625
 626
 627 ;;; Raw decoders
 628
 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)
 635            (type fixnum index))
 636   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 637     ;; Seven bits at a time, least significant bits first
 638     (loop with val = 0
 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)))
 642           until (i< byte 128)
 643           finally (progn
 644                     (assert (< val #.(ash 1 32)) ()
 645                             "The value ~D is longer than 32 bits" val)
 646                     (return (values val index))))))
 647
 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)
 652            (type fixnum index))
 653   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 654     ;; Seven bits at a time, least significant bits first
 655     (loop with val = 0
 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)))
 659           until (i< byte 128)
 660           finally (return (values val index)))))
 661
 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)
 666            (type fixnum index))
 667   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 668     ;; Eight bits at a time, least significant bits first
 669     (let ((val 0))
 670       (loop repeat 4
 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))))
 675
 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)
 680            (type fixnum index))
 681   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 682     ;; Eight bits at a time, least significant bits first
 683     (let ((val 0))
 684       (loop repeat 4
 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))))
 691
 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)
 696            (type fixnum index))
 697   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 698     ;; Eight bits at a time, least significant bits first
 699     (let ((val 0))
 700       (loop repeat 8
 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))))
 705
 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)
 710            (type fixnum index))
 711   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 712     ;; Eight bits at a time, least significant bits first
 713     (let ((val 0))
 714       (loop repeat 8
 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))))
 721
 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)
 726            (type fixnum index))
 727   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 728     ;; Eight bits at a time, least significant bits first
 729     (let ((bits 0))
 730       (loop repeat 4
 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))))
 737
 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)
 742            (type fixnum index))
 743   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 744     ;; Eight bits at a time, least significant bits first
 745     (let ((low  0)
 746           (high 0))
 747       (loop repeat 4
 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))))
 751       (loop repeat 4
 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))))
 759
 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)
 764            (type fixnum index))
 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)
 769                (type fixnum idx))
 770       (values (subseq buffer idx (i+ idx len)) (i+ idx len)))))
 771
 772 (defun zig-zag-decode32 (val)
 773   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 774     (logxor (ash val -1) (- (logand val 1)))))
 775
 776 (defun zig-zag-decode64 (val)
 777   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 778     (logxor (ash val -1) (- (logand val 1)))))
 779
 780
 781 ;;; Raw lengths
 782
 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)))
 788     (let ((size 0))
 789       (declare (type fixnum size))
 790       (loop do (progn
 791                  (setq val (ash val -7))
 792                  (iincf size))
 793             until (zerop val))
 794       size)))
 795
 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)))
 799     (let ((size 0))
 800       (declare (type fixnum size))
 801       (loop do (progn
 802                  (setq val (ash val -7))
 803                  (iincf size))
 804             until (zerop val))
 805       size)))