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 (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val))))
 154            ;; Call 'string' in case we are trying to serialize a symbol name
 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        (multiple-value-bind (val idx)
 343            (decode-octets buffer index)
 344          (let* ((val   (babel:octets-to-string val :encoding :utf-8))
 345                 (colon (position #\: val))
 346                 (pkg   (subseq val 0 colon))
 347                 (sym   (subseq val (i+ colon 1))))
 348            (values (intern sym pkg) 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 (i+ (length (package-name (symbol-package val))) 1 (length (symbol-name val)))))
 491          (i+ (length32 tag) (length32 len) len)))
 492       ((:date :time :datetime :timestamp)
 493        (i+ (length32 tag) 8)))))
 494
 495 (define-compiler-macro prim-size (&whole form val type tag)
 496   (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 497                      :fixed32 :sfixed32 :fixed64 :sfixed64
 498                      :string :bytes :bool :float :double))
 499     `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 500        ,(ecase type
 501           ((:int32 :uint32)
 502            `(i+ (length32 ,tag) (length32 ,val)))
 503           ((:int64 :uint64)
 504            `(i+ (length32 ,tag) (length64 ,val)))
 505           ((:sint32)
 506            `(i+ (length32 ,tag) (length32 (zig-zag-encode32 ,val))))
 507           ((:sint64)
 508            `(i+ (length32 ,tag) (length64 (zig-zag-encode64 ,val))))
 509           ((:fixed32 :sfixed32)
 510            `(i+ (length32 ,tag) 4))
 511           ((:fixed64 :sfixed64)
 512            `(i+ (length32 ,tag) 8))
 513           ((:string)
 514            `(let ((len (babel:string-size-in-octets ,val :encoding :utf-8)))
 515               (i+ (length32 ,tag) (length32 len) len)))
 516           ((:bytes)
 517            `(let ((len (length ,val)))
 518               (i+ (length32 ,tag) (length32 len) len)))
 519           ((:bool)
 520            `(i+ (length32 ,tag) 1))
 521           ((:float)
 522            `(i+ (length32 ,tag) 4))
 523           ((:double)
 524            `(i+ (length32 ,tag) 8))))
 525     form))
 526
 527 (defun packed-size (values type tag)
 528   "Returns the size in bytes that the packed object will take when serialized.
 529    Watch out, this function turns off most type checking."
 530   (declare (type (unsigned-byte 32) tag))
 531   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 532     (let ((len (let ((len 0))
 533                  (declare (type fixnum len))
 534                  (dolist (val values len)
 535                    (iincf len (ecase type
 536                                 ((:int32 :uint32) (length32 val))
 537                                 ((:int64 :uint64) (length64 val))
 538                                 ((:sint32) (length32 (zig-zag-encode32 val)))
 539                                 ((:sint64) (length64 (zig-zag-encode64 val)))
 540                                 ((:fixed32 :sfixed32) 4)
 541                                 ((:fixed64 :sfixed64) 8)
 542                                 ((:float) 4)
 543                                 ((:double) 8)))))))
 544       (declare (type (unsigned-byte 32) len))
 545       ;; Two value: the full size of the packed object, and the size
 546       ;; of just the payload
 547       (values (i+ (length32 tag) (length32 len) len) len))))
 548
 549 (define-compiler-macro packed-size (&whole form values type tag)
 550   (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 551                      :fixed32 :sfixed32 :fixed64 :sfixed64
 552                      :float :double))
 553     `(locally (declare (optimize (speed 3) (safety 0) (debug 0))
 554                        (type (unsigned-byte 32) tag))
 555        (let ((len (let ((len 0))
 556                     (declare (type fixnum len))
 557                     (dolist (val ,values len)
 558                       (iincf len ,(ecase type
 559                                     ((:int32 :uint32) `(length32 val))
 560                                     ((:int64 :uint64) `(length64 val))
 561                                     ((:sint32) `(length32 (zig-zag-encode32 val)))
 562                                     ((:sint64) `(length64 (zig-zag-encode64 val)))
 563                                     ((:fixed32 :sfixed32) `4)
 564                                     ((:fixed64 :sfixed64) `8)
 565                                     ((:float) `4)
 566                                     ((:double) `8)))))))
 567          (declare (type (unsigned-byte 32) len))
 568          (values (i+ (length32 ,tag) (length32 len) len) len)))
 569     form))
 570
 571 (defun enum-size (val values tag)
 572   "Returns the size in bytes that the enum object will take when serialized."
 573   (declare (type (unsigned-byte 32) tag))
 574   (let ((val (let ((e (find val values :key #'proto-value)))
 575                (and e (proto-index e)))))
 576     (declare (type (unsigned-byte 32) val))
 577     (i+ (length32 tag) (length32 val))))
 578
 579
 580 ;;; Raw encoders
 581
 582 (defun encode-uint32 (val buffer index)
 583   "Encodes the unsigned 32-bit integer 'val' as a varint into the buffer
 584    at the given index.
 585    Modifies the buffer, and returns the new index into the buffer.
 586    Watch out, this function turns off all type checking and array bounds checking."
 587   (declare (optimize (speed 3) (safety 0) (debug 0)))
 588   (declare (type (unsigned-byte 32) val)
 589            (type (simple-array (unsigned-byte 8)) buffer)
 590            (type fixnum index))
 591   ;; Seven bits at a time, least significant bits first
 592   (loop do (let ((bits (ldb #.(byte 7 0) val)))
 593              (declare (type (unsigned-byte 8) bits))
 594              (setq val (ash val -7))
 595              (setf (aref buffer index) (ilogior bits (if (zerop val) 0 128)))
 596              (iincf index))
 597         until (zerop val))
 598   (values index buffer))                        ;return the buffer to improve 'trace'
 599
 600 (defun encode-uint64 (val buffer index)
 601   "Encodes the unsigned 64-bit integer 'val' as a varint into the buffer
 602    at the given index.
 603    Modifies the buffer, and returns the new index into the buffer.
 604    Watch out, this function turns off all type checking and array bounds checking."
 605   (declare (optimize (speed 3) (safety 0) (debug 0)))
 606   (declare (type (unsigned-byte 64) val)
 607            (type (simple-array (unsigned-byte 8)) buffer)
 608            (type fixnum index))
 609   (loop do (let ((bits (ldb #.(byte 7 0) val)))
 610              (declare (type (unsigned-byte 8) bits))
 611              (setq val (ash val -7))
 612              (setf (aref buffer index) (ilogior bits (if (zerop val) 0 128)))
 613              (iincf index))
 614         until (zerop val))
 615   (values index buffer))
 616
 617 (defun encode-fixed32 (val buffer index)
 618   "Encodes the unsigned 32-bit integer 'val' as a fixed int into the buffer
 619    at the given index.
 620    Modifies the buffer, and returns the new index into the buffer.
 621    Watch out, this function turns off most type checking and all array bounds checking."
 622   (declare (type (unsigned-byte 32) val)
 623            (type (simple-array (unsigned-byte 8)) buffer)
 624            (type fixnum index))
 625   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 626     (loop repeat 4 doing
 627       (let ((byte (ldb #.(byte 8 0) val)))
 628         (declare (type (unsigned-byte 8) byte))
 629         (setq val (ash val -8))
 630         (setf (aref buffer index) byte)
 631         (iincf index))))
 632   (values index buffer))
 633
 634 (defun encode-fixed64 (val buffer index)
 635   "Encodes the unsigned 64-bit integer 'val' as a fixed int into the buffer
 636    at the given index.
 637    Modifies the buffer, and returns the new index into the buffer.
 638    Watch out, this function turns off most type checking and all array bounds checking."
 639   (declare (type (unsigned-byte 64) val)
 640            (type (simple-array (unsigned-byte 8)) buffer)
 641            (type fixnum index))
 642   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 643     (loop repeat 8 doing
 644       (let ((byte (ldb #.(byte 8 0) val)))
 645         (declare (type (unsigned-byte 8) byte))
 646         (setq val (ash val -8))
 647         (setf (aref buffer index) byte)
 648         (iincf index))))
 649   (values index buffer))
 650
 651 (defun encode-sfixed32 (val buffer index)
 652   "Encodes the signed 32-bit integer 'val' as a fixed int into the buffer
 653    at the given index.
 654    Modifies the buffer, and returns the new index into the buffer.
 655    Watch out, this function turns off most type checking and all array bounds checking."
 656   (declare (type (signed-byte 32) val)
 657            (type (simple-array (unsigned-byte 8)) buffer)
 658            (type fixnum index))
 659   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 660     (loop repeat 4 doing
 661       (let ((byte (ldb #.(byte 8 0) val)))
 662         (declare (type (unsigned-byte 8) byte))
 663         (setq val (ash val -8))
 664         (setf (aref buffer index) byte)
 665         (iincf index))))
 666   (values index buffer))
 667
 668 (defun encode-sfixed64 (val buffer index)
 669   "Encodes the signed 32-bit integer 'val' as a fixed int into the buffer
 670    at the given index.
 671    Modifies the buffer, and returns the new index into the buffer.
 672    Watch out, this function turns off most type checking and all array bounds checking."
 673   (declare (type (signed-byte 64) val)
 674            (type (simple-array (unsigned-byte 8)) buffer)
 675            (type fixnum index))
 676   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 677     (loop repeat 8 doing
 678       (let ((byte (ldb #.(byte 8 0) val)))
 679         (declare (type (unsigned-byte 8) byte))
 680         (setq val (ash val -8))
 681         (setf (aref buffer index) byte)
 682         (iincf index))))
 683   (values index buffer))
 684
 685 (defun encode-single (val buffer index)
 686   "Encodes the single float 'val' into the buffer at the given index.
 687    Modifies the buffer, and returns the new index into the buffer.
 688    Watch out, this function turns off most type checking and all array bounds checking."
 689   (declare (type single-float val)
 690            (type (simple-array (unsigned-byte 8)) buffer)
 691            (type fixnum index))
 692   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 693     (let ((bits (single-float-bits val)))
 694       (loop repeat 4 doing
 695         (let ((byte (ldb #.(byte 8 0) bits)))
 696           (declare (type (unsigned-byte 8) byte))
 697           (setq bits (ash bits -8))
 698           (setf (aref buffer index) byte)
 699           (iincf index)))))
 700   (values index buffer))
 701
 702 (defun encode-double (val buffer index)
 703   "Encodes the double float 'val' into the buffer at the given index.
 704    Modifies the buffer, and returns the new index into the buffer.
 705    Watch out, this function turns off most type checking and all array bounds checking."
 706   (declare (type double-float val)
 707            (type (simple-array (unsigned-byte 8)) buffer)
 708            (type fixnum index))
 709   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 710     (multiple-value-bind (low high)
 711         (double-float-bits val)
 712       (loop repeat 4 doing
 713         (let ((byte (ldb #.(byte 8 0) low)))
 714           (declare (type (unsigned-byte 8) byte))
 715           (setq low (ash low -8))
 716           (setf (aref buffer index) byte)
 717           (iincf index)))
 718       (loop repeat 4 doing
 719         (let ((byte (ldb #.(byte 8 0) high)))
 720           (declare (type (unsigned-byte 8) byte))
 721           (setq high (ash high -8))
 722           (setf (aref buffer index) byte)
 723           (iincf index)))))
 724   (values index buffer))
 725
 726 (defun encode-octets (octets buffer index)
 727   "Encodes the octets into the buffer at the given index.
 728    Modifies the buffer, and returns the new index into the buffer.
 729    Watch out, this function turns off most type checking and all array bounds checking."
 730   (declare (type (simple-array (unsigned-byte 8)) buffer)
 731            (type fixnum index))
 732   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 733     (let* ((len (length octets))
 734            (idx (encode-uint32 len buffer index)))
 735       (declare (type fixnum len)
 736                (type (unsigned-byte 32) idx))
 737       (replace buffer octets :start1 idx)
 738       (values (i+ idx len) buffer))))
 739
 740
 741 ;;; Raw decoders
 742
 743 ;; Decode the value from the buffer at the given index,
 744 ;; then return the value and new index into the buffer
 745 (defun decode-uint32 (buffer index)
 746   "Decodes the next 32-bit varint integer in the buffer at the given index.
 747    Returns both the decoded value and the new index into the buffer.
 748    Watch out, this function turns off most type checking and all array bounds checking."
 749   (declare (optimize (speed 3) (safety 0) (debug 0)))
 750   (declare (type (simple-array (unsigned-byte 8)) buffer)
 751            (type fixnum index))
 752   ;; Seven bits at a time, least significant bits first
 753   (loop with val = 0
 754         for places fixnum upfrom 0 by 7
 755         for byte fixnum = (prog1 (aref buffer index) (iincf index))
 756         do (setq val (logior val (ash (ldb #.(byte 7 0) byte) places)))
 757         until (i< byte 128)
 758         finally (progn
 759                   (assert (< val #.(ash 1 32)) ()
 760                           "The value ~D is longer than 32 bits" val)
 761                   (return (values val index)))))
 762
 763 (defun decode-uint64 (buffer index)
 764   "Decodes the next 64-bit varint integer in the buffer at the given index.
 765    Returns both the decoded value and the new index into the buffer.
 766    Watch out, this function turns off most type checking and all array bounds checking."
 767   (declare (optimize (speed 3) (safety 0) (debug 0)))
 768   (declare (type (simple-array (unsigned-byte 8)) buffer)
 769            (type fixnum index))
 770   ;; Seven bits at a time, least significant bits first
 771   (loop with val = 0
 772         for places fixnum upfrom 0 by 7
 773         for byte fixnum = (prog1 (aref buffer index) (iincf index))
 774         do (setq val (logior val (ash (ldb #.(byte 7 0) byte) places)))
 775         until (i< byte 128)
 776         finally (return (values val index))))
 777
 778 (defun decode-fixed32 (buffer index)
 779   "Decodes the next 32-bit unsigned fixed integer in the buffer at the given index.
 780    Returns both the decoded value and the new index into the buffer.
 781    Watch out, this function turns off most type checking and all array bounds checking."
 782   (declare (type (simple-array (unsigned-byte 8)) buffer)
 783            (type fixnum index))
 784   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 785     ;; Eight bits at a time, least significant bits first
 786     (let ((val 0))
 787       (loop repeat 4
 788             for places fixnum upfrom 0 by 8
 789             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 790             do (setq val (logior val (ash byte places))))
 791       (values val index))))
 792
 793 (defun decode-sfixed32 (buffer index)
 794   "Decodes the next 32-bit signed fixed integer in the buffer at the given index.
 795    Returns both the decoded value and the new index into the buffer.
 796    Watch out, this function turns off most type checking and all array bounds checking."
 797   (declare (type (simple-array (unsigned-byte 8)) buffer)
 798            (type fixnum index))
 799   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 800     ;; Eight bits at a time, least significant bits first
 801     (let ((val 0))
 802       (loop repeat 4
 803             for places fixnum upfrom 0 by 8
 804             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 805             do (setq val (logior val (ash byte places))))
 806       (when (i= (ldb #.(byte 1 31) val) 1)              ;sign bit set, so negative value
 807         (decf val #.(ash 1 32)))
 808       (values val index))))
 809
 810 (defun decode-fixed64 (buffer index)
 811   "Decodes the next unsigned 64-bit fixed integer in the buffer at the given index.
 812    Returns both the decoded value and the new index into the buffer.
 813    Watch out, this function turns off most type checking and all array bounds checking."
 814   (declare (type (simple-array (unsigned-byte 8)) buffer)
 815            (type fixnum index))
 816   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 817     ;; Eight bits at a time, least significant bits first
 818     (let ((val 0))
 819       (loop repeat 8
 820             for places fixnum upfrom 0 by 8
 821             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 822             do (setq val (logior val (ash byte places))))
 823       (values val index))))
 824
 825 (defun decode-sfixed64 (buffer index)
 826   "Decodes the next signed 64-bit fixed integer in the buffer at the given index.
 827    Returns both the decoded value and the new index into the buffer.
 828    Watch out, this function turns off most type checking and all array bounds checking."
 829   (declare (type (simple-array (unsigned-byte 8)) buffer)
 830            (type fixnum index))
 831   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 832     ;; Eight bits at a time, least significant bits first
 833     (let ((val 0))
 834       (loop repeat 8
 835             for places fixnum upfrom 0 by 8
 836             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 837             do (setq val (logior val (ash byte places))))
 838       (when (i= (ldb #.(byte 1 63) val) 1)             ;sign bit set, so negative value
 839         (decf val #.(ash 1 64)))
 840       (values val index))))
 841
 842 (defun decode-single (buffer index)
 843   "Decodes the next single float in the buffer at the given index.
 844    Returns both the decoded value and the new index into the buffer.
 845    Watch out, this function turns off most type checking and all array bounds checking."
 846   (declare (type (simple-array (unsigned-byte 8)) buffer)
 847            (type fixnum index))
 848   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 849     ;; Eight bits at a time, least significant bits first
 850     (let ((bits 0))
 851       (loop repeat 4
 852             for places fixnum upfrom 0 by 8
 853             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 854             do (setq bits (logior bits (ash byte places))))
 855       (when (i= (ldb #.(byte 1 31) bits) 1)             ;sign bit set, so negative value
 856         (decf bits #.(ash 1 32)))
 857       (values (make-single-float bits) index))))
 858
 859 (defun decode-double (buffer index)
 860   "Decodes the next double float in the buffer at the given index.
 861    Returns both the decoded value and the new index into the buffer.
 862    Watch out, this function turns off most type checking and all array bounds checking."
 863   (declare (type (simple-array (unsigned-byte 8)) buffer)
 864            (type fixnum index))
 865   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 866     ;; Eight bits at a time, least significant bits first
 867     (let ((low  0)
 868           (high 0))
 869       (loop repeat 4
 870             for places fixnum upfrom 0 by 8
 871             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 872             do (setq low (logior low (ash byte places))))
 873       (loop repeat 4
 874             for places fixnum upfrom 0 by 8
 875             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 876             do (setq high (logior high (ash byte places))))
 877       ;; High bits are signed, but low bits are unsigned
 878       (when (i= (ldb #.(byte 1 31) high) 1)             ;sign bit set, so negative value
 879         (decf high #.(ash 1 32)))
 880       (values (make-double-float low high) index))))
 881
 882 (defun decode-octets (buffer index)
 883   "Decodes the next octets in the buffer at the given index.
 884    Returns both the decoded value and the new index into the buffer.
 885    Watch out, this function turns off most type checking and all array bounds checking."
 886   (declare (type (simple-array (unsigned-byte 8)) buffer)
 887            (type fixnum index))
 888   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 889     (multiple-value-bind (len idx)
 890         (decode-uint32 buffer index)
 891       (declare (type (unsigned-byte 32) len)
 892                (type fixnum idx))
 893       (values (subseq buffer idx (i+ idx len)) (i+ idx len)))))
 894
 895
 896 ;;; Raw lengths
 897
 898 (defun length32 (val)
 899   "Returns the length that 'val' will take when encoded as a 32-bit integer."
 900   (declare (optimize (speed 3) (safety 0) (debug 0)))
 901   (let ((size 0))
 902     (declare (type fixnum size))
 903     (loop do (progn
 904                (setq val (ash val -7))
 905                (iincf size))
 906           until (zerop val))
 907     size))
 908
 909 (defun length64 (val)
 910   "Returns the length that 'val' will take when encoded as a 64-bit integer."
 911   (declare (optimize (speed 3) (safety 0) (debug 0)))
 912   (let ((size 0))
 913     (declare (type fixnum size))
 914     (loop do (progn
 915                (setq val (ash val -7))
 916                (iincf size))
 917           until (zerop val))
 918     size))
 919
 920
 921 ;;; Skipping elements
 922
 923 (defun skip-element (buffer index wire-type)
 924   "Skip an element in the buffer at the index of the given wire type.
 925    Returns the new index in the buffer.
 926    Watch out, this function turns off all type checking and all array bounds checking."
 927   (declare (optimize (speed 3) (safety 0) (debug 0)))
 928   (declare (type (simple-array (unsigned-byte 8)) buffer)
 929            (type fixnum index)
 930            (type (unsigned-byte 32) wire-type))
 931   (case wire-type
 932     (($wire-type-varint)
 933      (loop for byte fixnum = (prog1 (aref buffer index) (iincf index))
 934            until (i< byte 128))
 935      index)
 936     (($wire-type-string)
 937      (multiple-value-bind (len idx)
 938          (decode-uint32 buffer index)
 939        (declare (type (unsigned-byte 32) len)
 940                 (type fixnum idx))
 941        (i+ idx len)))
 942     (($wire-type-32bit)
 943      (i+ index 4))
 944     (($wire-type-64bit)
 945      (i+ index 8))))