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