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