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