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   "Given a wire type or the name of a Protobufs type and a field index,
  25    return the tag that encodes both of them."
  26   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
  27     (if (typep type 'fixnum)
  28       type
  29       (let ((type (ecase type
  30                     ((:int32 :uint32) $wire-type-varint)
  31                     ((:int64 :uint64) $wire-type-varint)
  32                     ((:sint32 :sint64) $wire-type-varint)
  33                     ((:fixed32 :sfixed32) $wire-type-32bit)
  34                     ((:fixed64 :sfixed64) $wire-type-64bit)
  35                     ((:string :bytes) $wire-type-string)
  36                     ((:bool) $wire-type-varint)
  37                     ((:float) $wire-type-32bit)
  38                     ((:double) $wire-type-64bit)
  39                     ;; A few of our homegrown types
  40                     ((:symbol) $wire-type-string)
  41                     ((:date :time :datetime :timestamp) $wire-type-64bit))))
  42         (ilogior type (iash index 3))))))
  43
  44 (define-compiler-macro make-tag (&whole form type index)
  45   (cond ((typep type 'fixnum)
  46          `(ilogior ,type (iash ,index 3)))
  47         ((keywordp type)
  48          (let ((type (ecase type
  49                        ((:int32 :uint32) $wire-type-varint)
  50                        ((:int64 :uint64) $wire-type-varint)
  51                        ((:sint32 :sint64) $wire-type-varint)
  52                        ((:fixed32 :sfixed32) $wire-type-32bit)
  53                        ((:fixed64 :sfixed64) $wire-type-64bit)
  54                        ((:string :bytes) $wire-type-string)
  55                        ((:bool) $wire-type-varint)
  56                        ((:float) $wire-type-32bit)
  57                        ((:double) $wire-type-64bit)
  58                        ;; A few of our homegrown types
  59                        ((:symbol) $wire-type-string)
  60                        ((:date :time :datetime :timestamp) $wire-type-64bit))))
  61            `(ilogior ,type (iash ,index 3))))
  62         (t form)))
  63
  64
  65 (defun zig-zag-encode32 (val)
  66   (declare (optimize (speed 3) (safety 0) (debug 0)))
  67   (declare (type (signed-byte 32) val))
  68   (logxor (ash val 1) (ash val -31)))
  69
  70 (defun zig-zag-encode64 (val)
  71   (declare (optimize (speed 3) (safety 0) (debug 0)))
  72   (declare (type (signed-byte 64) val))
  73   (logxor (ash val 1) (ash val -63)))
  74
  75 (define-compiler-macro zig-zag-encode32 (&whole form val)
  76   (if (atom val)
  77     `(locally (declare (optimize (speed 3) (safety 0) (debug 0))
  78                        (type (signed-byte 32) ,val))
  79        (logxor (ash ,val 1) (ash ,val -31)))
  80     form))
  81
  82 (define-compiler-macro zig-zag-encode64 (&whole form val)
  83   (if (atom val)
  84     `(locally (declare (optimize (speed 3) (safety 0) (debug 0))
  85                        (type (signed-byte 64) ,val))
  86        (logxor (ash ,val 1) (ash ,val -63)))
  87     form))
  88
  89 (defun zig-zag-decode32 (val)
  90   (declare (optimize (speed 3) (safety 0) (debug 0)))
  91   (logxor (ash val -1) (- (logand val 1))))
  92
  93 (defun zig-zag-decode64 (val)
  94   (declare (optimize (speed 3) (safety 0) (debug 0)))
  95   (logxor (ash val -1) (- (logand val 1))))
  96
  97 (define-compiler-macro zig-zag-decode32 (&whole form val)
  98   (if (atom val)
  99     `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 100        (logxor (ash ,val -1) (- (logand ,val 1))))
 101     form))
 102
 103 (define-compiler-macro zig-zag-decode64 (&whole form val)
 104   (if (atom val)
 105     `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 106        (logxor (ash ,val -1) (- (logand ,val 1))))
 107     form))
 108
 109
 110 ;;; Serializers
 111
 112 ;; Serialize 'val' of primitive type 'type' into the buffer
 113 (defun serialize-prim (val type tag buffer index)
 114   "Serializes a Protobufs primitive (scalar) value into the buffer at the given index.
 115    The value is given by 'val', the primitive type by 'type'.
 116    Modifies the buffer in place, and returns the new index into the buffer.
 117    Watch out, this function turns off most type checking and all array bounds checking."
 118   (declare (type (simple-array (unsigned-byte 8)) buffer)
 119            (type (unsigned-byte 32) tag)
 120            (type fixnum index))
 121   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 122     (let ((idx (encode-uint32 tag buffer index)))
 123       (declare (type fixnum idx))
 124       (ecase type
 125         ((:int32 :uint32)
 126          (encode-uint32 val buffer idx))
 127         ((:int64 :uint64)
 128          (encode-uint64 val buffer idx))
 129         ((:sint32)
 130          (encode-uint32 (zig-zag-encode32 val) buffer idx))
 131         ((:sint64)
 132          (encode-uint64 (zig-zag-encode64 val) buffer idx))
 133         ((:fixed32)
 134          (encode-fixed32 val buffer idx))
 135         ((:sfixed32)
 136          (encode-sfixed32 val buffer idx))
 137         ((:fixed64)
 138          (encode-fixed64 val buffer idx))
 139         ((:sfixed64)
 140          (encode-sfixed64 val buffer idx))
 141         ((:string)
 142          (encode-octets (babel:string-to-octets val :encoding :utf-8) buffer idx))
 143         ((:bytes)
 144          (encode-octets val buffer idx))
 145         ((:bool)
 146          (encode-uint32 (if val 1 0) buffer idx))
 147         ((:float)
 148          (encode-single val buffer idx))
 149         ((:double)
 150          (encode-double val buffer idx))
 151         ;; A few of our homegrown types
 152         ((:symbol)
 153          ;; Note that this is consy, avoid it if possible
 154          (let ((val (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val))))
 155            (encode-octets (babel:string-to-octets val :encoding :utf-8) buffer idx)))
 156         ((:date :time :datetime :timestamp)
 157          (encode-uint64 val buffer idx))))))
 158
 159 (define-compiler-macro serialize-prim (&whole form val type tag buffer index)
 160   (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 161                      :fixed32 :sfixed32 :fixed64 :sfixed64
 162                      :string :bytes :bool :float :double))
 163     `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 164        (let ((idx (encode-uint32 ,tag ,buffer ,index)))
 165          (declare (type fixnum idx))
 166          ,(ecase type
 167             ((:int32 :uint32)
 168              `(encode-uint32 ,val ,buffer idx))
 169             ((:int64 :uint64)
 170              `(encode-uint64 ,val ,buffer idx))
 171             ((:sint32)
 172              `(encode-uint32 (zig-zag-encode32 ,val) ,buffer idx))
 173             ((:sint64)
 174              `(encode-uint64 (zig-zag-encode64 ,val) ,buffer idx))
 175             ((:fixed32)
 176              `(encode-fixed32 ,val ,buffer idx))
 177             ((:sfixed32)
 178              `(encode-sfixed32 ,val ,buffer idx))
 179             ((:fixed64)
 180              `(encode-fixed64 ,val ,buffer idx))
 181             ((:sfixed64)
 182              `(encode-sfixed64 ,val ,buffer idx))
 183             ((:string)
 184              `(encode-octets (babel:string-to-octets ,val :encoding :utf-8) ,buffer idx))
 185             ((:bytes)
 186              `(encode-octets ,val ,buffer idx))
 187             ((:bool)
 188              `(encode-uint32 (if ,val 1 0) ,buffer idx))
 189             ((:float)
 190              `(encode-single ,val ,buffer idx))
 191             ((:double)
 192              `(encode-double ,val ,buffer idx)))))
 193     form))
 194
 195 (defun serialize-packed (values type tag buffer index)
 196   "Serializes a set of packed values into the buffer at the given index.
 197    The values are given by 'values', the primitive type by 'type'.
 198    Modifies the buffer in place, and returns the new index into the buffer.
 199    Watch out, this function turns off most type checking and all array bounds checking."
 200   (declare (type (simple-array (unsigned-byte 8)) buffer)
 201            (type (unsigned-byte 32) tag)
 202            (type fixnum index))
 203   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 204     (let ((idx (encode-uint32 tag buffer index)))
 205       (declare (type fixnum idx))
 206       (multiple-value-bind (full-len len)
 207           (packed-size values type tag)
 208         (declare (type fixnum len) (ignore full-len))
 209         (setq idx (encode-uint32 len buffer idx)))
 210       (ecase type
 211         ((:int32 :uint32)
 212          (dolist (val values idx)
 213            (setq idx (encode-uint32 val buffer idx))))
 214         ((:int64 :uint64)
 215          (dolist (val values idx)
 216            (setq idx (encode-uint64 val buffer idx))))
 217         ((:sint32)
 218          (dolist (val values idx)
 219            (setq idx (encode-uint32 (zig-zag-encode32 val) buffer idx))))
 220         ((:sint64)
 221          (dolist (val values idx)
 222            (setq idx (encode-uint64 (zig-zag-encode64 val) buffer idx))))
 223         ((:fixed32)
 224          (dolist (val values idx)
 225            (setq idx (encode-fixed32 val buffer idx))))
 226         ((:sfixed32)
 227          (dolist (val values idx)
 228            (setq idx (encode-sfixed32 val buffer idx))))
 229         ((:fixed64)
 230          (dolist (val values idx)
 231            (setq idx (encode-fixed64 val buffer idx))))
 232         ((:sfixed64)
 233          (dolist (val values idx)
 234            (setq idx (encode-sfixed64 val buffer idx))))
 235         ((:float)
 236          (dolist (val values idx)
 237            (setq idx (encode-single val buffer idx))))
 238         ((:double)
 239          (dolist (val values idx)
 240            (setq idx (encode-double val buffer idx))))))))
 241
 242 (define-compiler-macro serialize-packed (&whole form values type tag buffer index)
 243   (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 244                      :fixed32 :sfixed32 :fixed64 :sfixed64
 245                      :float :double))
 246     `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 247        (let ((idx (encode-uint32 ,tag ,buffer ,index)))
 248          (declare (type fixnum idx))
 249          (multiple-value-bind (full-len len)
 250              (packed-size ,values ,type ,tag)
 251            (declare (type fixnum len) (ignore full-len))
 252            (setq idx (encode-uint32 len ,buffer idx)))
 253          (dolist (val ,values idx)
 254            ,(ecase type
 255               ((:int32 :uint32)
 256                `(setq idx (encode-uint32 val ,buffer idx)))
 257               ((:int64 :uint64)
 258                `(setq idx (encode-uint64 val ,buffer idx)))
 259               ((:sint32)
 260                `(setq idx (encode-uint32 (zig-zag-encode32 val) ,buffer idx)))
 261               ((:sint64)
 262                `(setq idx (encode-uint64 (zig-zag-encode64 val) ,buffer idx)))
 263               ((:fixed32)
 264                `(setq idx (encode-fixed32 val ,buffer idx)))
 265               ((:sfixed32)
 266                `(setq idx (encode-sfixed32 val ,buffer idx)))
 267               ((:fixed64)
 268                `(setq idx (encode-fixed64 val ,buffer idx)))
 269               ((:sfixed64)
 270                `(setq idx (encode-sfixed64 val ,buffer idx)))
 271               ((:float)
 272                `(setq idx (encode-single val ,buffer idx)))
 273               ((:double)
 274                `(setq idx (encode-double val ,buffer idx)))))))
 275     form))
 276
 277 (defun serialize-enum (val values tag buffer index)
 278   "Serializes a Protobufs enum value into the buffer at the given index.
 279    The value is given by 'val', the enum values are in 'values'.
 280    Modifies the buffer in place, and returns the new index into the buffer.
 281    Watch out, this function turns off most type checking and all array bounds checking."
 282   (declare (type (simple-array (unsigned-byte 8)) buffer)
 283            (type (unsigned-byte 32) tag)
 284            (type fixnum index))
 285   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 286     (let* ((val (let ((e (find val values :key #'proto-value)))
 287                   (and e (proto-index e))))
 288            (idx (encode-uint32 tag buffer index)))
 289       (declare (type (unsigned-byte 32) val)
 290                (type fixnum idx))
 291       (encode-uint32 val buffer idx))))
 292
 293
 294 ;;; Deserializers
 295
 296 ;; Deserialize the next object of type 'type'
 297 (defun deserialize-prim (type buffer index)
 298   "Deserializes the next object of primitive type 'type'.
 299    Deserializes from the byte vector 'buffer' starting at 'index'.
 300    Returns the value and and the new index into the buffer.
 301    Watch out, this function turns off most type checking and all array bounds checking."
 302   (declare (type (simple-array (unsigned-byte 8)) buffer)
 303            (type fixnum index))
 304   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 305     (ecase type
 306       ((:int32 :uint32)
 307        (decode-uint32 buffer index))
 308       ((:int64 :uint64)
 309        (decode-uint64 buffer index))
 310       ((:sint32)
 311        (multiple-value-bind (val idx)
 312            (decode-uint32 buffer index)
 313          (values (zig-zag-decode32 val) idx)))
 314       ((:sint64)
 315        (multiple-value-bind (val idx)
 316            (decode-uint64 buffer index)
 317          (values (zig-zag-decode64 val) idx)))
 318       ((:fixed32)
 319        (decode-fixed32 buffer index))
 320       ((:sfixed32)
 321        (decode-sfixed32 buffer index))
 322       ((:fixed64)
 323        (decode-fixed64 buffer index))
 324       ((:sfixed64)
 325        (decode-sfixed64 buffer index))
 326       ((:string)
 327        (multiple-value-bind (val idx)
 328            (decode-octets buffer index)
 329          (values (babel:octets-to-string val :encoding :utf-8) idx)))
 330       ((:bytes)
 331        (decode-octets buffer index))
 332       ((:bool)
 333        (multiple-value-bind (val idx)
 334            (decode-uint32 buffer index)
 335          (values (if (zerop val) nil t) idx)))
 336       ((:float)
 337        (decode-single buffer index))
 338       ((:double)
 339        (decode-double buffer index))
 340       ;; A few of our homegrown types
 341       ((:symbol)
 342        ;; Note that this is consy, avoid it if possible
 343        (multiple-value-bind (val idx)
 344            (decode-octets buffer index)
 345          (let* ((val   (babel:octets-to-string val :encoding :utf-8))
 346                 (colon (position #\: val))
 347                 (pkg   (subseq val 0 colon))
 348                 (sym   (subseq val (i+ colon 1))))
 349            (values (intern sym pkg) idx))))
 350       ((:date :time :datetime :timestamp)
 351        (decode-uint64 buffer index)))))
 352
 353 (define-compiler-macro deserialize-prim (&whole form type buffer index)
 354   (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 355                      :fixed32 :sfixed32 :fixed64 :sfixed64
 356                      :string :bytes :bool :float :double))
 357     `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 358        ,(ecase type
 359           ((:int32 :uint32)
 360            `(decode-uint32 ,buffer ,index))
 361           ((:int64 :uint64)
 362            `(decode-uint64 ,buffer ,index))
 363           ((:sint32)
 364            `(multiple-value-bind (val idx)
 365                 (decode-uint32 ,buffer ,index)
 366               (values (zig-zag-decode32 val) idx)))
 367           ((:sint64)
 368            `(multiple-value-bind (val idx)
 369                (decode-uint64 ,buffer ,index)
 370              (values (zig-zag-decode64 val) idx)))
 371           ((:fixed32)
 372            `(decode-fixed32 ,buffer ,index))
 373           ((:sfixed32)
 374            `(decode-sfixed32 ,buffer ,index))
 375           ((:fixed64)
 376            `(decode-fixed64 ,buffer ,index))
 377           ((:sfixed64)
 378            `(decode-sfixed64 ,buffer ,index))
 379           ((:string)
 380            `(multiple-value-bind (val idx)
 381                 (decode-octets ,buffer ,index)
 382               (values (babel:octets-to-string val :encoding :utf-8) idx)))
 383           ((:bytes)
 384            `(decode-octets ,buffer ,index))
 385           ((:bool)
 386            `(multiple-value-bind (val idx)
 387                 (decode-uint32 ,buffer ,index)
 388               (values (if (zerop val) nil t) idx)))
 389           ((:float)
 390            `(decode-single ,buffer ,index))
 391           ((:double)
 392            `(decode-double ,buffer ,index))))
 393     form))
 394
 395 (defun deserialize-packed (type buffer index)
 396   "Deserializes the next packed values of type 'type'.
 397    Deserializes from the byte vector 'buffer' starting at 'index'.
 398    Returns the value and and the new index into the buffer.
 399    Watch out, this function turns off most type checking and all array bounds checking."
 400   (declare (type (simple-array (unsigned-byte 8)) buffer)
 401            (type fixnum index))
 402   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 403     (multiple-value-bind (len idx)
 404         (decode-uint32 buffer index)
 405       (declare (type (unsigned-byte 32) len)
 406                (type fixnum idx))
 407       (let ((end (i+ idx len)))
 408         (declare (type (unsigned-byte 32) end))
 409         (with-collectors ((values collect-value))
 410           (loop
 411             (when (>= idx end)
 412               (return-from deserialize-packed (values values idx)))
 413             (multiple-value-bind (val nidx)
 414                 (ecase type
 415                   ((:int32 :uint32)
 416                    (decode-uint32 buffer idx))
 417                   ((:int64 :uint64)
 418                    (decode-uint64 buffer idx))
 419                   ((:sint32)
 420                    (multiple-value-bind (val idx)
 421                        (decode-uint32 buffer idx)
 422                      (values (zig-zag-decode32 val) idx)))
 423                   ((:sint64)
 424                    (multiple-value-bind (val idx)
 425                        (decode-uint64 buffer idx)
 426                      (values (zig-zag-decode64 val) idx)))
 427                   ((:fixed32)
 428                    (decode-fixed32 buffer idx))
 429                   ((:sfixed32)
 430                    (decode-sfixed32 buffer idx))
 431                   ((:fixed64)
 432                    (decode-fixed64 buffer idx))
 433                   ((:sfixed64)
 434                    (decode-sfixed64 buffer idx))
 435                   ((:float)
 436                    (decode-single buffer idx))
 437                   ((:double)
 438                    (decode-double buffer idx)))
 439               (collect-value val)
 440               (setq idx nidx))))))))
 441
 442 (defun deserialize-enum (values buffer index)
 443   "Deserializes the next enum value take from 'values'.
 444    Deserializes from the byte vector 'buffer' starting at 'index'.
 445    Returns the value and and the new index into the buffer.
 446    Watch out, this function turns off most type checking and all array bounds checking."
 447   (declare (type (simple-array (unsigned-byte 8)) buffer)
 448            (type fixnum index))
 449   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 450     (multiple-value-bind (val idx)
 451         (decode-uint32 buffer index)
 452       (let ((val (let ((e (find val values :key #'proto-index)))
 453                    (and e (proto-value e)))))
 454         (values val idx)))))
 455
 456
 457 ;;; Object sizing
 458
 459 (defun prim-size (val type tag)
 460   "Returns the size in bytes that the primitive object will take when serialized.
 461    Watch out, this function turns off most type checking."
 462   (declare (type (unsigned-byte 32) tag))
 463   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 464     (ecase type
 465       ((:int32 :uint32)
 466        (i+ (length32 tag) (length32 val)))
 467       ((:int64 :uint64)
 468        (i+ (length32 tag) (length64 val)))
 469       ((:sint32)
 470        (i+ (length32 tag) (length32 (zig-zag-encode32 val))))
 471       ((:sint64)
 472        (i+ (length32 tag) (length64 (zig-zag-encode64 val))))
 473       ((:fixed32 :sfixed32)
 474        (i+ (length32 tag) 4))
 475       ((:fixed64 :sfixed64)
 476        (i+ (length32 tag) 8))
 477       ((:string)
 478        (let ((len (babel:string-size-in-octets val :encoding :utf-8)))
 479          (i+ (length32 tag) (length32 len) len)))
 480       ((:bytes)
 481        (let ((len (length val)))
 482          (i+ (length32 tag) (length32 len) len)))
 483       ((:bool)
 484        (i+ (length32 tag) 1))
 485       ((:float)
 486        (i+ (length32 tag) 4))
 487       ((:double)
 488        (i+ (length32 tag) 8))
 489       ;; A few of our homegrown types
 490       ((:symbol)
 491        (let* ((len (i+ (length (package-name (symbol-package val))) 1 (length (symbol-name val)))))
 492          (i+ (length32 tag) (length32 len) len)))
 493       ((:date :time :datetime :timestamp)
 494        (i+ (length32 tag) 8)))))
 495
 496 (define-compiler-macro prim-size (&whole form val type tag)
 497   (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 498                      :fixed32 :sfixed32 :fixed64 :sfixed64
 499                      :string :bytes :bool :float :double))
 500     `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 501        ,(ecase type
 502           ((:int32 :uint32)
 503            `(i+ (length32 ,tag) (length32 ,val)))
 504           ((:int64 :uint64)
 505            `(i+ (length32 ,tag) (length64 ,val)))
 506           ((:sint32)
 507            `(i+ (length32 ,tag) (length32 (zig-zag-encode32 ,val))))
 508           ((:sint64)
 509            `(i+ (length32 ,tag) (length64 (zig-zag-encode64 ,val))))
 510           ((:fixed32 :sfixed32)
 511            `(i+ (length32 ,tag) 4))
 512           ((:fixed64 :sfixed64)
 513            `(i+ (length32 ,tag) 8))
 514           ((:string)
 515            `(let ((len (babel:string-size-in-octets ,val :encoding :utf-8)))
 516               (i+ (length32 ,tag) (length32 len) len)))
 517           ((:bytes)
 518            `(let ((len (length ,val)))
 519               (i+ (length32 ,tag) (length32 len) len)))
 520           ((:bool)
 521            `(i+ (length32 ,tag) 1))
 522           ((:float)
 523            `(i+ (length32 ,tag) 4))
 524           ((:double)
 525            `(i+ (length32 ,tag) 8))))
 526     form))
 527
 528 (defun packed-size (values type tag)
 529   "Returns the size in bytes that the packed object will take when serialized.
 530    Watch out, this function turns off most type checking."
 531   (declare (type (unsigned-byte 32) tag))
 532   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 533     (let ((len (let ((len 0))
 534                  (declare (type fixnum len))
 535                  (dolist (val values len)
 536                    (iincf len (ecase type
 537                                 ((:int32 :uint32) (length32 val))
 538                                 ((:int64 :uint64) (length64 val))
 539                                 ((:sint32) (length32 (zig-zag-encode32 val)))
 540                                 ((:sint64) (length64 (zig-zag-encode64 val)))
 541                                 ((:fixed32 :sfixed32) 4)
 542                                 ((:fixed64 :sfixed64) 8)
 543                                 ((:float) 4)
 544                                 ((:double) 8)))))))
 545       (declare (type (unsigned-byte 32) len))
 546       ;; Two value: the full size of the packed object, and the size
 547       ;; of just the payload
 548       (values (i+ (length32 tag) (length32 len) len) len))))
 549
 550 (define-compiler-macro packed-size (&whole form values type tag)
 551   (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 552                      :fixed32 :sfixed32 :fixed64 :sfixed64
 553                      :float :double))
 554     `(locally (declare (optimize (speed 3) (safety 0) (debug 0))
 555                        (type (unsigned-byte 32) tag))
 556        (let ((len (let ((len 0))
 557                     (declare (type fixnum len))
 558                     (dolist (val ,values len)
 559                       (iincf len ,(ecase type
 560                                     ((:int32 :uint32) `(length32 val))
 561                                     ((:int64 :uint64) `(length64 val))
 562                                     ((:sint32) `(length32 (zig-zag-encode32 val)))
 563                                     ((:sint64) `(length64 (zig-zag-encode64 val)))
 564                                     ((:fixed32 :sfixed32) `4)
 565                                     ((:fixed64 :sfixed64) `8)
 566                                     ((:float) `4)
 567                                     ((:double) `8)))))))
 568          (declare (type (unsigned-byte 32) len))
 569          (values (i+ (length32 ,tag) (length32 len) len) len)))
 570     form))
 571
 572 (defun enum-size (val values tag)
 573   "Returns the size in bytes that the enum object will take when serialized."
 574   (declare (type (unsigned-byte 32) tag))
 575   (let ((val (let ((e (find val values :key #'proto-value)))
 576                (and e (proto-index e)))))
 577     (declare (type (unsigned-byte 32) val))
 578     (i+ (length32 tag) (length32 val))))
 579
 580
 581 ;;; Raw encoders
 582
 583 (defun encode-uint32 (val buffer index)
 584   "Encodes the unsigned 32-bit integer 'val' as a varint into the buffer
 585    at the given index.
 586    Modifies the buffer, and returns the new index into the buffer.
 587    Watch out, this function turns off all type checking and array bounds checking."
 588   (declare (optimize (speed 3) (safety 0) (debug 0)))
 589   (declare (type (unsigned-byte 32) val)
 590            (type (simple-array (unsigned-byte 8)) buffer)
 591            (type fixnum index))
 592   ;; Seven bits at a time, least significant bits first
 593   (loop do (let ((bits (ldb #.(byte 7 0) val)))
 594              (declare (type (unsigned-byte 8) bits))
 595              (setq val (ash val -7))
 596              (setf (aref buffer index) (ilogior bits (if (zerop val) 0 128)))
 597              (iincf index))
 598         until (zerop val))
 599   (values index buffer))                        ;return the buffer to improve 'trace'
 600
 601 (defun encode-uint64 (val buffer index)
 602   "Encodes the unsigned 64-bit integer 'val' as a varint into the buffer
 603    at the given index.
 604    Modifies the buffer, and returns the new index into the buffer.
 605    Watch out, this function turns off all type checking and array bounds checking."
 606   (declare (optimize (speed 3) (safety 0) (debug 0)))
 607   (declare (type (unsigned-byte 64) val)
 608            (type (simple-array (unsigned-byte 8)) buffer)
 609            (type fixnum index))
 610   (loop do (let ((bits (ldb #.(byte 7 0) val)))
 611              (declare (type (unsigned-byte 8) bits))
 612              (setq val (ash val -7))
 613              (setf (aref buffer index) (ilogior bits (if (zerop val) 0 128)))
 614              (iincf index))
 615         until (zerop val))
 616   (values index buffer))
 617
 618 (defun encode-fixed32 (val buffer index)
 619   "Encodes the unsigned 32-bit integer 'val' as a fixed int into the buffer
 620    at the given index.
 621    Modifies the buffer, and returns the new index into the buffer.
 622    Watch out, this function turns off most type checking and all array bounds checking."
 623   (declare (type (unsigned-byte 32) val)
 624            (type (simple-array (unsigned-byte 8)) buffer)
 625            (type fixnum index))
 626   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 627     (loop repeat 4 doing
 628       (let ((byte (ldb #.(byte 8 0) val)))
 629         (declare (type (unsigned-byte 8) byte))
 630         (setq val (ash val -8))
 631         (setf (aref buffer index) byte)
 632         (iincf index))))
 633   (values index buffer))
 634
 635 (defun encode-fixed64 (val buffer index)
 636   "Encodes the unsigned 64-bit integer 'val' as a fixed int into the buffer
 637    at the given index.
 638    Modifies the buffer, and returns the new index into the buffer.
 639    Watch out, this function turns off most type checking and all array bounds checking."
 640   (declare (type (unsigned-byte 64) val)
 641            (type (simple-array (unsigned-byte 8)) buffer)
 642            (type fixnum index))
 643   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 644     (loop repeat 8 doing
 645       (let ((byte (ldb #.(byte 8 0) val)))
 646         (declare (type (unsigned-byte 8) byte))
 647         (setq val (ash val -8))
 648         (setf (aref buffer index) byte)
 649         (iincf index))))
 650   (values index buffer))
 651
 652 (defun encode-sfixed32 (val buffer index)
 653   "Encodes the signed 32-bit integer 'val' as a fixed int into the buffer
 654    at the given index.
 655    Modifies the buffer, and returns the new index into the buffer.
 656    Watch out, this function turns off most type checking and all array bounds checking."
 657   (declare (type (signed-byte 32) val)
 658            (type (simple-array (unsigned-byte 8)) buffer)
 659            (type fixnum index))
 660   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 661     (loop repeat 4 doing
 662       (let ((byte (ldb #.(byte 8 0) val)))
 663         (declare (type (unsigned-byte 8) byte))
 664         (setq val (ash val -8))
 665         (setf (aref buffer index) byte)
 666         (iincf index))))
 667   (values index buffer))
 668
 669 (defun encode-sfixed64 (val buffer index)
 670   "Encodes the signed 32-bit integer 'val' as a fixed int into the buffer
 671    at the given index.
 672    Modifies the buffer, and returns the new index into the buffer.
 673    Watch out, this function turns off most type checking and all array bounds checking."
 674   (declare (type (signed-byte 64) val)
 675            (type (simple-array (unsigned-byte 8)) buffer)
 676            (type fixnum index))
 677   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 678     (loop repeat 8 doing
 679       (let ((byte (ldb #.(byte 8 0) val)))
 680         (declare (type (unsigned-byte 8) byte))
 681         (setq val (ash val -8))
 682         (setf (aref buffer index) byte)
 683         (iincf index))))
 684   (values index buffer))
 685
 686 (defun encode-single (val buffer index)
 687   "Encodes the single float 'val' into the buffer at the given index.
 688    Modifies the buffer, and returns the new index into the buffer.
 689    Watch out, this function turns off most type checking and all array bounds checking."
 690   (declare (type single-float val)
 691            (type (simple-array (unsigned-byte 8)) buffer)
 692            (type fixnum index))
 693   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 694     (let ((bits (single-float-bits val)))
 695       (loop repeat 4 doing
 696         (let ((byte (ldb #.(byte 8 0) bits)))
 697           (declare (type (unsigned-byte 8) byte))
 698           (setq bits (ash bits -8))
 699           (setf (aref buffer index) byte)
 700           (iincf index)))))
 701   (values index buffer))
 702
 703 (defun encode-double (val buffer index)
 704   "Encodes the double float 'val' into the buffer at the given index.
 705    Modifies the buffer, and returns the new index into the buffer.
 706    Watch out, this function turns off most type checking and all array bounds checking."
 707   (declare (type double-float val)
 708            (type (simple-array (unsigned-byte 8)) buffer)
 709            (type fixnum index))
 710   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 711     (multiple-value-bind (low high)
 712         (double-float-bits val)
 713       (loop repeat 4 doing
 714         (let ((byte (ldb #.(byte 8 0) low)))
 715           (declare (type (unsigned-byte 8) byte))
 716           (setq low (ash low -8))
 717           (setf (aref buffer index) byte)
 718           (iincf index)))
 719       (loop repeat 4 doing
 720         (let ((byte (ldb #.(byte 8 0) high)))
 721           (declare (type (unsigned-byte 8) byte))
 722           (setq high (ash high -8))
 723           (setf (aref buffer index) byte)
 724           (iincf index)))))
 725   (values index buffer))
 726
 727 (defun encode-octets (octets buffer index)
 728   "Encodes the octets into the buffer at the given index.
 729    Modifies the buffer, and returns the new index into the buffer.
 730    Watch out, this function turns off most type checking and all array bounds checking."
 731   (declare (type (simple-array (unsigned-byte 8)) buffer)
 732            (type fixnum index))
 733   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 734     (let* ((len (length octets))
 735            (idx (encode-uint32 len buffer index)))
 736       (declare (type fixnum len)
 737                (type (unsigned-byte 32) idx))
 738       (replace buffer octets :start1 idx)
 739       (values (i+ idx len) buffer))))
 740
 741
 742 ;;; Raw decoders
 743
 744 ;; Decode the value from the buffer at the given index,
 745 ;; then return the value and new index into the buffer
 746 (defun decode-uint32 (buffer index)
 747   "Decodes the next 32-bit varint integer in the buffer at the given index.
 748    Returns both the decoded value and the new index into the buffer.
 749    Watch out, this function turns off most type checking and all array bounds checking."
 750   (declare (optimize (speed 3) (safety 0) (debug 0)))
 751   (declare (type (simple-array (unsigned-byte 8)) buffer)
 752            (type fixnum index))
 753   ;; Seven bits at a time, least significant bits first
 754   (loop with val = 0
 755         for places fixnum upfrom 0 by 7
 756         for byte fixnum = (prog1 (aref buffer index) (iincf index))
 757         do (setq val (logior val (ash (ldb #.(byte 7 0) byte) places)))
 758         until (i< byte 128)
 759         finally (progn
 760                   (assert (< val #.(ash 1 32)) ()
 761                           "The value ~D is longer than 32 bits" val)
 762                   (return (values val index)))))
 763
 764 (defun decode-uint64 (buffer index)
 765   "Decodes the next 64-bit varint integer in the buffer at the given index.
 766    Returns both the decoded value and the new index into the buffer.
 767    Watch out, this function turns off most type checking and all array bounds checking."
 768   (declare (optimize (speed 3) (safety 0) (debug 0)))
 769   (declare (type (simple-array (unsigned-byte 8)) buffer)
 770            (type fixnum index))
 771   ;; Seven bits at a time, least significant bits first
 772   (loop with val = 0
 773         for places fixnum upfrom 0 by 7
 774         for byte fixnum = (prog1 (aref buffer index) (iincf index))
 775         do (setq val (logior val (ash (ldb #.(byte 7 0) byte) places)))
 776         until (i< byte 128)
 777         finally (return (values val index))))
 778
 779 (defun decode-fixed32 (buffer index)
 780   "Decodes the next 32-bit unsigned fixed integer in the buffer at the given index.
 781    Returns both the decoded value and the new index into the buffer.
 782    Watch out, this function turns off most type checking and all array bounds checking."
 783   (declare (type (simple-array (unsigned-byte 8)) buffer)
 784            (type fixnum index))
 785   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 786     ;; Eight bits at a time, least significant bits first
 787     (let ((val 0))
 788       (loop repeat 4
 789             for places fixnum upfrom 0 by 8
 790             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 791             do (setq val (logior val (ash byte places))))
 792       (values val index))))
 793
 794 (defun decode-sfixed32 (buffer index)
 795   "Decodes the next 32-bit signed fixed integer in the buffer at the given index.
 796    Returns both the decoded value and the new index into the buffer.
 797    Watch out, this function turns off most type checking and all array bounds checking."
 798   (declare (type (simple-array (unsigned-byte 8)) buffer)
 799            (type fixnum index))
 800   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 801     ;; Eight bits at a time, least significant bits first
 802     (let ((val 0))
 803       (loop repeat 4
 804             for places fixnum upfrom 0 by 8
 805             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 806             do (setq val (logior val (ash byte places))))
 807       (when (i= (ldb #.(byte 1 31) val) 1)              ;sign bit set, so negative value
 808         (decf val #.(ash 1 32)))
 809       (values val index))))
 810
 811 (defun decode-fixed64 (buffer index)
 812   "Decodes the next unsigned 64-bit fixed integer in the buffer at the given index.
 813    Returns both the decoded value and the new index into the buffer.
 814    Watch out, this function turns off most type checking and all array bounds checking."
 815   (declare (type (simple-array (unsigned-byte 8)) buffer)
 816            (type fixnum index))
 817   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 818     ;; Eight bits at a time, least significant bits first
 819     (let ((val 0))
 820       (loop repeat 8
 821             for places fixnum upfrom 0 by 8
 822             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 823             do (setq val (logior val (ash byte places))))
 824       (values val index))))
 825
 826 (defun decode-sfixed64 (buffer index)
 827   "Decodes the next signed 64-bit fixed integer in the buffer at the given index.
 828    Returns both the decoded value and the new index into the buffer.
 829    Watch out, this function turns off most type checking and all array bounds checking."
 830   (declare (type (simple-array (unsigned-byte 8)) buffer)
 831            (type fixnum index))
 832   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 833     ;; Eight bits at a time, least significant bits first
 834     (let ((val 0))
 835       (loop repeat 8
 836             for places fixnum upfrom 0 by 8
 837             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 838             do (setq val (logior val (ash byte places))))
 839       (when (i= (ldb #.(byte 1 63) val) 1)             ;sign bit set, so negative value
 840         (decf val #.(ash 1 64)))
 841       (values val index))))
 842
 843 (defun decode-single (buffer index)
 844   "Decodes the next single float in the buffer at the given index.
 845    Returns both the decoded value and the new index into the buffer.
 846    Watch out, this function turns off most type checking and all array bounds checking."
 847   (declare (type (simple-array (unsigned-byte 8)) buffer)
 848            (type fixnum index))
 849   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 850     ;; Eight bits at a time, least significant bits first
 851     (let ((bits 0))
 852       (loop repeat 4
 853             for places fixnum upfrom 0 by 8
 854             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 855             do (setq bits (logior bits (ash byte places))))
 856       (when (i= (ldb #.(byte 1 31) bits) 1)             ;sign bit set, so negative value
 857         (decf bits #.(ash 1 32)))
 858       (values (make-single-float bits) index))))
 859
 860 (defun decode-double (buffer index)
 861   "Decodes the next double float in the buffer at the given index.
 862    Returns both the decoded value and the new index into the buffer.
 863    Watch out, this function turns off most type checking and all array bounds checking."
 864   (declare (type (simple-array (unsigned-byte 8)) buffer)
 865            (type fixnum index))
 866   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 867     ;; Eight bits at a time, least significant bits first
 868     (let ((low  0)
 869           (high 0))
 870       (loop repeat 4
 871             for places fixnum upfrom 0 by 8
 872             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 873             do (setq low (logior low (ash byte places))))
 874       (loop repeat 4
 875             for places fixnum upfrom 0 by 8
 876             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 877             do (setq high (logior high (ash byte places))))
 878       ;; High bits are signed, but low bits are unsigned
 879       (when (i= (ldb #.(byte 1 31) high) 1)             ;sign bit set, so negative value
 880         (decf high #.(ash 1 32)))
 881       (values (make-double-float low high) index))))
 882
 883 (defun decode-octets (buffer index)
 884   "Decodes the next octets in the buffer at the given index.
 885    Returns both the decoded value and the new index into the buffer.
 886    Watch out, this function turns off most type checking and all array bounds checking."
 887   (declare (type (simple-array (unsigned-byte 8)) buffer)
 888            (type fixnum index))
 889   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 890     (multiple-value-bind (len idx)
 891         (decode-uint32 buffer index)
 892       (declare (type (unsigned-byte 32) len)
 893                (type fixnum idx))
 894       (values (subseq buffer idx (i+ idx len)) (i+ idx len)))))
 895
 896
 897 ;;; Raw lengths
 898
 899 (defun length32 (val)
 900   "Returns the length that 'val' will take when encoded as a 32-bit integer."
 901   (declare (optimize (speed 3) (safety 0) (debug 0)))
 902   (let ((size 0))
 903     (declare (type fixnum size))
 904     (loop do (progn
 905                (setq val (ash val -7))
 906                (iincf size))
 907           until (zerop val))
 908     size))
 909
 910 (defun length64 (val)
 911   "Returns the length that 'val' will take when encoded as a 64-bit integer."
 912   (declare (optimize (speed 3) (safety 0) (debug 0)))
 913   (let ((size 0))
 914     (declare (type fixnum size))
 915     (loop do (progn
 916                (setq val (ash val -7))
 917                (iincf size))
 918           until (zerop val))
 919     size))
 920
 921
 922 ;;; Skipping elements
 923
 924 (defun skip-element (buffer index wire-type)
 925   "Skip an element in the buffer at the index of the given wire type.
 926    Returns the new index in the buffer.
 927    Watch out, this function turns off all type checking and all array bounds checking."
 928   (declare (optimize (speed 3) (safety 0) (debug 0)))
 929   (declare (type (simple-array (unsigned-byte 8)) buffer)
 930            (type fixnum index)
 931            (type (unsigned-byte 32) wire-type))
 932   (case wire-type
 933     (($wire-type-varint)
 934      (loop for byte fixnum = (prog1 (aref buffer index) (iincf index))
 935            until (i< byte 128))
 936      index)
 937     (($wire-type-string)
 938      (multiple-value-bind (len idx)
 939          (decode-uint32 buffer index)
 940        (declare (type (unsigned-byte 32) len)
 941                 (type fixnum idx))
 942        (i+ idx len)))
 943     (($wire-type-32bit)
 944      (i+ index 4))
 945     (($wire-type-64bit)
 946      (i+ index 8))))