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-string val 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-string val 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-string ,val ,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        (decode-string buffer index))
 330       ((:bytes)
 331        (decode-octets buffer index))
 332       ((:bool)
 333        (multiple-value-bind (val idx)
 334            (decode-uint32 buffer index)
 335          (values (if (zerop val) nil t) idx)))
 336       ((:float)
 337        (decode-single buffer index))
 338       ((:double)
 339        (decode-double buffer index))
 340       ;; A few of our homegrown types
 341       ((:symbol)
 342        ;; Note that this is consy, avoid it if possible
 343        (multiple-value-bind (val idx)
 344            (decode-string buffer index)
 345          (values (make-lisp-symbol val) idx)))
 346       ((:date :time :datetime :timestamp)
 347        (decode-uint64 buffer index)))))
 348
 349 (define-compiler-macro deserialize-prim (&whole form type buffer index)
 350   (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 351                      :fixed32 :sfixed32 :fixed64 :sfixed64
 352                      :string :bytes :bool :float :double))
 353     `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 354        ,(ecase type
 355           ((:int32 :uint32)
 356            `(decode-uint32 ,buffer ,index))
 357           ((:int64 :uint64)
 358            `(decode-uint64 ,buffer ,index))
 359           ((:sint32)
 360            `(multiple-value-bind (val idx)
 361                 (decode-uint32 ,buffer ,index)
 362               (values (zig-zag-decode32 val) idx)))
 363           ((:sint64)
 364            `(multiple-value-bind (val idx)
 365                (decode-uint64 ,buffer ,index)
 366              (values (zig-zag-decode64 val) idx)))
 367           ((:fixed32)
 368            `(decode-fixed32 ,buffer ,index))
 369           ((:sfixed32)
 370            `(decode-sfixed32 ,buffer ,index))
 371           ((:fixed64)
 372            `(decode-fixed64 ,buffer ,index))
 373           ((:sfixed64)
 374            `(decode-sfixed64 ,buffer ,index))
 375           ((:string)
 376            `(decode-string ,buffer ,index))
 377           ((:bytes)
 378            `(decode-octets ,buffer ,index))
 379           ((:bool)
 380            `(multiple-value-bind (val idx)
 381                 (decode-uint32 ,buffer ,index)
 382               (values (if (zerop val) nil t) idx)))
 383           ((:float)
 384            `(decode-single ,buffer ,index))
 385           ((:double)
 386            `(decode-double ,buffer ,index))))
 387     form))
 388
 389 (defun deserialize-packed (type buffer index)
 390   "Deserializes the next packed values of type 'type'.
 391    Deserializes from the byte vector 'buffer' starting at 'index'.
 392    Returns the value and and the new index into the buffer.
 393    Watch out, this function turns off most type checking and all array bounds checking."
 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    Watch out, this function turns off most type checking and all array bounds checking."
 441   (declare (type (simple-array (unsigned-byte 8)) buffer)
 442            (type fixnum index))
 443   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 444     (multiple-value-bind (val idx)
 445         (decode-uint32 buffer index)
 446       (let ((val (let ((e (find val values :key #'proto-index)))
 447                    (and e (proto-value e)))))
 448         (values val idx)))))
 449
 450
 451 ;;; Object sizing
 452
 453 (defun prim-size (val type tag)
 454   "Returns the size in bytes that the primitive object will take when serialized.
 455    Watch out, this function turns off most type checking."
 456   (declare (type (unsigned-byte 32) tag))
 457   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 458     (ecase type
 459       ((:int32 :uint32)
 460        (i+ (length32 tag) (length32 val)))
 461       ((:int64 :uint64)
 462        (i+ (length32 tag) (length64 val)))
 463       ((:sint32)
 464        (i+ (length32 tag) (length32 (zig-zag-encode32 val))))
 465       ((:sint64)
 466        (i+ (length32 tag) (length64 (zig-zag-encode64 val))))
 467       ((:fixed32 :sfixed32)
 468        (i+ (length32 tag) 4))
 469       ((:fixed64 :sfixed64)
 470        (i+ (length32 tag) 8))
 471       ((:string)
 472        (let ((len (babel:string-size-in-octets val :encoding :utf-8)))
 473          (i+ (length32 tag) (length32 len) len)))
 474       ((:bytes)
 475        (let ((len (length val)))
 476          (i+ (length32 tag) (length32 len) len)))
 477       ((:bool)
 478        (i+ (length32 tag) 1))
 479       ((:float)
 480        (i+ (length32 tag) 4))
 481       ((:double)
 482        (i+ (length32 tag) 8))
 483       ;; A few of our homegrown types
 484       ((:symbol)
 485        (let ((len (if (keywordp val)
 486                     (length (symbol-name val))
 487                     (i+ (length (package-name (symbol-package val))) 1 (length (symbol-name val))))))
 488          (i+ (length32 tag) (length32 len) len)))
 489       ((:date :time :datetime :timestamp)
 490        (i+ (length32 tag) 8)))))
 491
 492 (define-compiler-macro prim-size (&whole form val type tag)
 493   (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 494                      :fixed32 :sfixed32 :fixed64 :sfixed64
 495                      :string :bytes :bool :float :double))
 496     `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 497        ,(ecase type
 498           ((:int32 :uint32)
 499            `(i+ (length32 ,tag) (length32 ,val)))
 500           ((:int64 :uint64)
 501            `(i+ (length32 ,tag) (length64 ,val)))
 502           ((:sint32)
 503            `(i+ (length32 ,tag) (length32 (zig-zag-encode32 ,val))))
 504           ((:sint64)
 505            `(i+ (length32 ,tag) (length64 (zig-zag-encode64 ,val))))
 506           ((:fixed32 :sfixed32)
 507            `(i+ (length32 ,tag) 4))
 508           ((:fixed64 :sfixed64)
 509            `(i+ (length32 ,tag) 8))
 510           ((:string)
 511            `(let ((len (babel:string-size-in-octets ,val :encoding :utf-8)))
 512               (i+ (length32 ,tag) (length32 len) len)))
 513           ((:bytes)
 514            `(let ((len (length ,val)))
 515               (i+ (length32 ,tag) (length32 len) len)))
 516           ((:bool)
 517            `(i+ (length32 ,tag) 1))
 518           ((:float)
 519            `(i+ (length32 ,tag) 4))
 520           ((:double)
 521            `(i+ (length32 ,tag) 8))))
 522     form))
 523
 524 (defun packed-size (values type tag)
 525   "Returns the size in bytes that the packed object will take when serialized.
 526    Watch out, this function turns off most type checking."
 527   (declare (type (unsigned-byte 32) tag))
 528   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 529     (let ((len (let ((len 0))
 530                  (declare (type fixnum len))
 531                  (dolist (val values len)
 532                    (iincf len (ecase type
 533                                 ((:int32 :uint32) (length32 val))
 534                                 ((:int64 :uint64) (length64 val))
 535                                 ((:sint32) (length32 (zig-zag-encode32 val)))
 536                                 ((:sint64) (length64 (zig-zag-encode64 val)))
 537                                 ((:fixed32 :sfixed32) 4)
 538                                 ((:fixed64 :sfixed64) 8)
 539                                 ((:float) 4)
 540                                 ((:double) 8)))))))
 541       (declare (type (unsigned-byte 32) len))
 542       ;; Two value: the full size of the packed object, and the size
 543       ;; of just the payload
 544       (values (i+ (length32 tag) (length32 len) len) len))))
 545
 546 (define-compiler-macro packed-size (&whole form values type tag)
 547   (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 548                      :fixed32 :sfixed32 :fixed64 :sfixed64
 549                      :float :double))
 550     `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 551        (let ((len (let ((len 0))
 552                     (declare (type fixnum len))
 553                     (dolist (val ,values len)
 554                       (iincf len ,(ecase type
 555                                     ((:int32 :uint32) `(length32 val))
 556                                     ((:int64 :uint64) `(length64 val))
 557                                     ((:sint32) `(length32 (zig-zag-encode32 val)))
 558                                     ((:sint64) `(length64 (zig-zag-encode64 val)))
 559                                     ((:fixed32 :sfixed32) `4)
 560                                     ((:fixed64 :sfixed64) `8)
 561                                     ((:float) `4)
 562                                     ((:double) `8)))))))
 563          (declare (type (unsigned-byte 32) len))
 564          (values (i+ (length32 (the (unsigned-byte 32) ,tag)) (length32 len) len) len)))
 565     form))
 566
 567 (defun enum-size (val values tag)
 568   "Returns the size in bytes that the enum object will take when serialized."
 569   (declare (type (unsigned-byte 32) tag))
 570   (let ((idx (let ((e (find val values :key #'proto-value)))
 571                (and e (proto-index e)))))
 572     (assert idx () "There is no enum value for ~S" val)
 573     (i+ (length32 tag) (length32 idx))))
 574
 575
 576 ;;; Raw encoders
 577
 578 (defun encode-uint32 (val buffer index)
 579   "Encodes the unsigned 32-bit integer 'val' as a varint into the buffer
 580    at the given index.
 581    Modifies the buffer, and returns the new index into the buffer.
 582    Watch out, this function turns off all type checking and array bounds checking."
 583   (declare (optimize (speed 3) (safety 0) (debug 0)))
 584   (declare (type (unsigned-byte 32) val)
 585            (type (simple-array (unsigned-byte 8)) buffer)
 586            (type fixnum index))
 587   ;; Seven bits at a time, least significant bits first
 588   (loop do (let ((bits (ldb (byte 7 0) val)))
 589              (declare (type (unsigned-byte 8) bits))
 590              (setq val (ash val -7))
 591              (setf (aref buffer index) (ilogior bits (if (zerop val) 0 128)))
 592              (iincf index))
 593         until (zerop val))
 594   (values index buffer))                        ;return the buffer to improve 'trace'
 595
 596 (defun encode-uint64 (val buffer index)
 597   "Encodes the unsigned 64-bit integer 'val' as a varint into the buffer
 598    at the given index.
 599    Modifies the buffer, and returns the new index into the buffer.
 600    Watch out, this function turns off all type checking and array bounds checking."
 601   (declare (optimize (speed 3) (safety 0) (debug 0)))
 602   (declare (type (unsigned-byte 64) val)
 603            (type (simple-array (unsigned-byte 8)) buffer)
 604            (type fixnum index))
 605   (loop do (let ((bits (ldb (byte 7 0) val)))
 606              (declare (type (unsigned-byte 8) bits))
 607              (setq val (ash val -7))
 608              (setf (aref buffer index) (ilogior bits (if (zerop val) 0 128)))
 609              (iincf index))
 610         until (zerop val))
 611   (values index buffer))
 612
 613 (defun encode-fixed32 (val buffer index)
 614   "Encodes the unsigned 32-bit integer 'val' as a fixed int into the buffer
 615    at the given index.
 616    Modifies the buffer, and returns the new index into the buffer.
 617    Watch out, this function turns off most type checking and all array bounds checking."
 618   (declare (type (unsigned-byte 32) val)
 619            (type (simple-array (unsigned-byte 8)) buffer)
 620            (type fixnum index))
 621   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 622     (loop repeat 4 doing
 623       (let ((byte (ldb (byte 8 0) val)))
 624         (declare (type (unsigned-byte 8) byte))
 625         (setq val (ash val -8))
 626         (setf (aref buffer index) byte)
 627         (iincf index))))
 628   (values index buffer))
 629
 630 (defun encode-fixed64 (val buffer index)
 631   "Encodes the unsigned 64-bit integer 'val' as a fixed int into the buffer
 632    at the given index.
 633    Modifies the buffer, and returns the new index into the buffer.
 634    Watch out, this function turns off most type checking and all array bounds checking."
 635   (declare (type (unsigned-byte 64) val)
 636            (type (simple-array (unsigned-byte 8)) buffer)
 637            (type fixnum index))
 638   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 639     (loop repeat 8 doing
 640       (let ((byte (ldb (byte 8 0) val)))
 641         (declare (type (unsigned-byte 8) byte))
 642         (setq val (ash val -8))
 643         (setf (aref buffer index) byte)
 644         (iincf index))))
 645   (values index buffer))
 646
 647 (defun encode-sfixed32 (val buffer index)
 648   "Encodes the signed 32-bit integer 'val' as a fixed int into the buffer
 649    at the given index.
 650    Modifies the buffer, and returns the new index into the buffer.
 651    Watch out, this function turns off most type checking and all array bounds checking."
 652   (declare (type (signed-byte 32) val)
 653            (type (simple-array (unsigned-byte 8)) buffer)
 654            (type fixnum index))
 655   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 656     (loop repeat 4 doing
 657       (let ((byte (ldb (byte 8 0) val)))
 658         (declare (type (unsigned-byte 8) byte))
 659         (setq val (ash val -8))
 660         (setf (aref buffer index) byte)
 661         (iincf index))))
 662   (values index buffer))
 663
 664 (defun encode-sfixed64 (val buffer index)
 665   "Encodes the signed 32-bit integer 'val' as a fixed int into the buffer
 666    at the given index.
 667    Modifies the buffer, and returns the new index into the buffer.
 668    Watch out, this function turns off most type checking and all array bounds checking."
 669   (declare (type (signed-byte 64) val)
 670            (type (simple-array (unsigned-byte 8)) buffer)
 671            (type fixnum index))
 672   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 673     (loop repeat 8 doing
 674       (let ((byte (ldb (byte 8 0) val)))
 675         (declare (type (unsigned-byte 8) byte))
 676         (setq val (ash val -8))
 677         (setf (aref buffer index) byte)
 678         (iincf index))))
 679   (values index buffer))
 680
 681 (defun encode-single (val buffer index)
 682   "Encodes the single float 'val' into the buffer at the given index.
 683    Modifies the buffer, and returns the new index into the buffer.
 684    Watch out, this function turns off most type checking and all array bounds checking."
 685   (declare (type single-float val)
 686            (type (simple-array (unsigned-byte 8)) buffer)
 687            (type fixnum index))
 688   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 689     (let ((bits (single-float-bits val)))
 690       (loop repeat 4 doing
 691         (let ((byte (ldb (byte 8 0) bits)))
 692           (declare (type (unsigned-byte 8) byte))
 693           (setq bits (ash bits -8))
 694           (setf (aref buffer index) byte)
 695           (iincf index)))))
 696   (values index buffer))
 697
 698 (defun encode-double (val buffer index)
 699   "Encodes the double float 'val' into the buffer at the given index.
 700    Modifies the buffer, and returns the new index into the buffer.
 701    Watch out, this function turns off most type checking and all array bounds checking."
 702   (declare (type double-float val)
 703            (type (simple-array (unsigned-byte 8)) buffer)
 704            (type fixnum index))
 705   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 706     (multiple-value-bind (low high)
 707         (double-float-bits val)
 708       (loop repeat 4 doing
 709         (let ((byte (ldb (byte 8 0) low)))
 710           (declare (type (unsigned-byte 8) byte))
 711           (setq low (ash low -8))
 712           (setf (aref buffer index) byte)
 713           (iincf index)))
 714       (loop repeat 4 doing
 715         (let ((byte (ldb (byte 8 0) high)))
 716           (declare (type (unsigned-byte 8) byte))
 717           (setq high (ash high -8))
 718           (setf (aref buffer index) byte)
 719           (iincf index)))))
 720   (values index buffer))
 721
 722 (defun encode-string (string buffer index)
 723   "Encodes the octets into the buffer at the given index.
 724    Modifies the buffer, and returns the new index into the buffer.
 725    Watch out, this function turns off most type checking and all array bounds checking."
 726   (declare (type (simple-array (unsigned-byte 8)) buffer)
 727            (type fixnum index))
 728   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 729     (let* ((octets (babel:string-to-octets string :encoding :utf-8))
 730            (len (length octets))
 731            (idx (encode-uint32 len buffer index)))
 732       (declare (type fixnum len)
 733                (type (unsigned-byte 32) idx))
 734       (replace buffer octets :start1 idx)
 735       (values (i+ idx len) buffer))))
 736
 737 (defun encode-octets (octets buffer index)
 738   "Encodes the octets into the buffer at the given index.
 739    Modifies the buffer, and returns the new index into the buffer.
 740    Watch out, this function turns off most type checking and all array bounds checking."
 741   (declare (type (simple-array (unsigned-byte 8)) buffer)
 742            (type fixnum index))
 743   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 744     (let* ((len (length octets))
 745            (idx (encode-uint32 len buffer index)))
 746       (declare (type fixnum len)
 747                (type (unsigned-byte 32) idx))
 748       (replace buffer octets :start1 idx)
 749       (values (i+ idx len) buffer))))
 750
 751
 752 ;;; Raw decoders
 753
 754 ;; Decode the value from the buffer at the given index,
 755 ;; then return the value and new index into the buffer
 756 (defun decode-uint32 (buffer index)
 757   "Decodes the next 32-bit varint integer in the buffer at the given index.
 758    Returns both the decoded value and the new index into the buffer.
 759    Watch out, this function turns off most type checking and all array bounds checking."
 760   (declare (optimize (speed 3) (safety 0) (debug 0)))
 761   (declare (type (simple-array (unsigned-byte 8)) buffer)
 762            (type fixnum index))
 763   ;; Seven bits at a time, least significant bits first
 764   (loop with val = 0
 765         for places fixnum upfrom 0 by 7
 766         for byte fixnum = (prog1 (aref buffer index) (iincf index))
 767         do (setq val (logior val (ash (ldb (byte 7 0) byte) places)))
 768         until (i< byte 128)
 769         finally (progn
 770                   (assert (< val #.(ash 1 32)) ()
 771                           "The value ~D is longer than 32 bits" val)
 772                   (return (values val index)))))
 773
 774 (defun decode-uint64 (buffer index)
 775   "Decodes the next 64-bit varint integer in the buffer at the given index.
 776    Returns both the decoded value and the new index into the buffer.
 777    Watch out, this function turns off most type checking and all array bounds checking."
 778   (declare (optimize (speed 3) (safety 0) (debug 0)))
 779   (declare (type (simple-array (unsigned-byte 8)) buffer)
 780            (type fixnum index))
 781   ;; Seven bits at a time, least significant bits first
 782   (loop with val = 0
 783         for places fixnum upfrom 0 by 7
 784         for byte fixnum = (prog1 (aref buffer index) (iincf index))
 785         do (setq val (logior val (ash (ldb (byte 7 0) byte) places)))
 786         until (i< byte 128)
 787         finally (return (values val index))))
 788
 789 (defun decode-fixed32 (buffer index)
 790   "Decodes the next 32-bit unsigned fixed integer in the buffer at the given index.
 791    Returns both the decoded value and the new index into the buffer.
 792    Watch out, this function turns off most type checking and all array bounds checking."
 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 4
 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-sfixed32 (buffer index)
 805   "Decodes the next 32-bit signed fixed integer in the buffer at the given index.
 806    Returns both the decoded value and the new index into the buffer.
 807    Watch out, this function turns off most type checking and all array bounds checking."
 808   (declare (type (simple-array (unsigned-byte 8)) buffer)
 809            (type fixnum index))
 810   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 811     ;; Eight bits at a time, least significant bits first
 812     (let ((val 0))
 813       (loop repeat 4
 814             for places fixnum upfrom 0 by 8
 815             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 816             do (setq val (logior val (ash byte places))))
 817       (when (i= (ldb (byte 1 31) val) 1)              ;sign bit set, so negative value
 818         (decf val #.(ash 1 32)))
 819       (values val index))))
 820
 821 (defun decode-fixed64 (buffer index)
 822   "Decodes the next unsigned 64-bit fixed integer in the buffer at the given index.
 823    Returns both the decoded value and the new index into the buffer.
 824    Watch out, this function turns off most type checking and all array bounds checking."
 825   (declare (type (simple-array (unsigned-byte 8)) buffer)
 826            (type fixnum index))
 827   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 828     ;; Eight bits at a time, least significant bits first
 829     (let ((val 0))
 830       (loop repeat 8
 831             for places fixnum upfrom 0 by 8
 832             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 833             do (setq val (logior val (ash byte places))))
 834       (values val index))))
 835
 836 (defun decode-sfixed64 (buffer index)
 837   "Decodes the next signed 64-bit fixed integer in the buffer at the given index.
 838    Returns both the decoded value and the new index into the buffer.
 839    Watch out, this function turns off most type checking and all array bounds checking."
 840   (declare (type (simple-array (unsigned-byte 8)) buffer)
 841            (type fixnum index))
 842   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 843     ;; Eight bits at a time, least significant bits first
 844     (let ((val 0))
 845       (loop repeat 8
 846             for places fixnum upfrom 0 by 8
 847             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 848             do (setq val (logior val (ash byte places))))
 849       (when (i= (ldb (byte 1 63) val) 1)             ;sign bit set, so negative value
 850         (decf val #.(ash 1 64)))
 851       (values val index))))
 852
 853 (defun decode-single (buffer index)
 854   "Decodes the next single float in the buffer at the given index.
 855    Returns both the decoded value and the new index into the buffer.
 856    Watch out, this function turns off most type checking and all array bounds checking."
 857   (declare (type (simple-array (unsigned-byte 8)) buffer)
 858            (type fixnum index))
 859   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 860     ;; Eight bits at a time, least significant bits first
 861     (let ((bits 0))
 862       (loop repeat 4
 863             for places fixnum upfrom 0 by 8
 864             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 865             do (setq bits (logior bits (ash byte places))))
 866       (when (i= (ldb (byte 1 31) bits) 1)             ;sign bit set, so negative value
 867         (decf bits #.(ash 1 32)))
 868       (values (make-single-float bits) index))))
 869
 870 (defun decode-double (buffer index)
 871   "Decodes the next double float in the buffer at the given index.
 872    Returns both the decoded value and the new index into the buffer.
 873    Watch out, this function turns off most type checking and all array bounds checking."
 874   (declare (type (simple-array (unsigned-byte 8)) buffer)
 875            (type fixnum index))
 876   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 877     ;; Eight bits at a time, least significant bits first
 878     (let ((low  0)
 879           (high 0))
 880       (loop repeat 4
 881             for places fixnum upfrom 0 by 8
 882             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 883             do (setq low (logior low (ash byte places))))
 884       (loop repeat 4
 885             for places fixnum upfrom 0 by 8
 886             for byte fixnum = (prog1 (aref buffer index) (iincf index))
 887             do (setq high (logior high (ash byte places))))
 888       ;; High bits are signed, but low bits are unsigned
 889       (when (i= (ldb (byte 1 31) high) 1)             ;sign bit set, so negative value
 890         (decf high #.(ash 1 32)))
 891       (values (make-double-float low high) index))))
 892
 893 (defun decode-string (buffer index)
 894   "Decodes the next UTF-8 encoded string in the buffer at the given index.
 895    Returns both the decoded string and the new index into the buffer.
 896    Watch out, this function turns off most type checking and all array bounds checking."
 897   (declare (type (simple-array (unsigned-byte 8)) buffer)
 898            (type fixnum index))
 899   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 900     (multiple-value-bind (len idx)
 901         (decode-uint32 buffer index)
 902       (declare (type (unsigned-byte 32) len)
 903                (type fixnum idx))
 904       (values (babel:octets-to-string buffer :start idx :end (i+ idx len) :encoding :utf-8) (i+ idx len)))))
 905
 906 (defun decode-octets (buffer index)
 907   "Decodes the next octets in the buffer at the given index.
 908    Returns both the decoded value and the new index into the buffer.
 909    Watch out, this function turns off most type checking and all array bounds checking."
 910   (declare (type (simple-array (unsigned-byte 8)) buffer)
 911            (type fixnum index))
 912   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 913     (multiple-value-bind (len idx)
 914         (decode-uint32 buffer index)
 915       (declare (type (unsigned-byte 32) len)
 916                (type fixnum idx))
 917       (values (subseq buffer idx (i+ idx len)) (i+ idx len)))))
 918
 919
 920 ;;; Raw lengths
 921
 922 (defun length32 (val)
 923   "Returns the length that 'val' will take when encoded as a 32-bit integer."
 924   (declare (optimize (speed 3) (safety 0) (debug 0)))
 925   (let ((size 0))
 926     (declare (type fixnum size))
 927     (loop do (progn
 928                (setq val (ash val -7))
 929                (iincf size))
 930           until (zerop val))
 931     size))
 932
 933 (defun length64 (val)
 934   "Returns the length that 'val' will take when encoded as a 64-bit integer."
 935   (declare (optimize (speed 3) (safety 0) (debug 0)))
 936   (let ((size 0))
 937     (declare (type fixnum size))
 938     (loop do (progn
 939                (setq val (ash val -7))
 940                (iincf size))
 941           until (zerop val))
 942     size))
 943
 944
 945 ;;; Skipping elements
 946
 947 (defun skip-element (buffer index wire-type)
 948   "Skip an element in the buffer at the index of the given wire type.
 949    Returns the new index in the buffer.
 950    Watch out, this function turns off all type checking and all array bounds checking."
 951   (declare (optimize (speed 3) (safety 0) (debug 0)))
 952   (declare (type (simple-array (unsigned-byte 8)) buffer)
 953            (type fixnum index)
 954            (type (unsigned-byte 32) wire-type))
 955   (case wire-type
 956     (($wire-type-varint)
 957      (loop for byte fixnum = (prog1 (aref buffer index) (iincf index))
 958            until (i< byte 128))
 959      index)
 960     (($wire-type-string)
 961      (multiple-value-bind (len idx)
 962          (decode-uint32 buffer index)
 963        (declare (type (unsigned-byte 32) len)
 964                 (type fixnum idx))
 965        (i+ idx len)))
 966     (($wire-type-32bit)
 967      (i+ index 4))
 968     (($wire-type-64bit)
 969      (i+ index 8))
 970     (t index)))