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        (multiple-value-bind (len idx)
 458            (decode-uint32 .buffer ,index)
 459          (declare (type (unsigned-byte 32) len)
 460                   (type fixnum idx))
 461          (let ((end (i+ idx len)))
 462            (declare (type (unsigned-byte 32) end))
 463            (with-collectors ((values collect-value))
 464              (loop
 465                (when (>= idx end)
 466                  (return-from deserialize-packed (values values idx)))
 467                (multiple-value-bind (val nidx)
 468                    ,(ecase type
 469                       ((:int32 :uint32)
 470                        `(decode-uint32 ,buffer idx))
 471                       ((:int64 :uint64)
 472                        `(decode-uint64 ,buffer idx))
 473                       ((:sint32)
 474                        `(multiple-value-bind (val idx)
 475                             (decode-uint32 ,buffer idx)
 476                           (values (zig-zag-decode32 val) idx)))
 477                       ((:sint64)
 478                        `(multiple-value-bind (val idx)
 479                             (decode-uint64 ,buffer idx)
 480                           (values (zig-zag-decode64 val) idx)))
 481                       ((:fixed32)
 482                        `(decode-fixed32 ,buffer idx))
 483                       ((:sfixed32)
 484                        `(decode-sfixed32 ,buffer idx))
 485                       ((:fixed64)
 486                        `(decode-fixed64 ,buffer idx))
 487                       ((:sfixed64)
 488                        `(decode-sfixed64 ,buffer idx))
 489                       ((:float)
 490                        `(decode-single ,buffer idx))
 491                       ((:double)
 492                        `(decode-double ,buffer idx)))
 493                  (collect-value val)
 494                  (setq idx nidx)))))))
 495     form))
 496
 497 (defun deserialize-enum (values buffer index)
 498   "Deserializes the next enum value take from 'values'.
 499    Deserializes from the byte vector 'buffer' starting at 'index'.
 500    Returns the value and and the new index into the buffer.
 501    Watch out, this function turns off most type checking and all array bounds checking."
 502   (declare (type (simple-array (unsigned-byte 8)) buffer)
 503            (type fixnum index))
 504   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 505     (multiple-value-bind (val idx)
 506         (decode-uint32 buffer index)
 507       (let ((val (let ((e (find val values :key #'proto-index)))
 508                    (and e (proto-value e)))))
 509         (values val idx)))))
 510
 511
 512 ;;; Object sizing
 513
 514 (defun prim-size (val type tag)
 515   "Returns the size in bytes that the primitive object will take when serialized.
 516    Watch out, this function turns off most type checking."
 517   (declare (type (unsigned-byte 32) tag))
 518   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 519     (ecase type
 520       ((:int32 :uint32)
 521        (i+ (length32 tag) (length32 val)))
 522       ((:int64 :uint64)
 523        (i+ (length32 tag) (length64 val)))
 524       ((:sint32)
 525        (i+ (length32 tag) (length32 (zig-zag-encode32 val))))
 526       ((:sint64)
 527        (i+ (length32 tag) (length64 (zig-zag-encode64 val))))
 528       ((:fixed32 :sfixed32)
 529        (i+ (length32 tag) 4))
 530       ((:fixed64 :sfixed64)
 531        (i+ (length32 tag) 8))
 532       ((:string)
 533        (let ((len (babel:string-size-in-octets val :encoding :utf-8)))
 534          (i+ (length32 tag) (length32 len) len)))
 535       ((:bytes)
 536        (let ((len (length val)))
 537          (i+ (length32 tag) (length32 len) len)))
 538       ((:bool)
 539        (i+ (length32 tag) 1))
 540       ((:float)
 541        (i+ (length32 tag) 4))
 542       ((:double)
 543        (i+ (length32 tag) 8))
 544       ;; A few of our homegrown types
 545       ((:symbol)
 546        (let ((len (if (keywordp val)
 547                     (length (symbol-name val))
 548                     (i+ (length (package-name (symbol-package val))) 1 (length (symbol-name val))))))
 549          (i+ (length32 tag) (length32 len) len)))
 550       ((:date :time :datetime :timestamp)
 551        (i+ (length32 tag) 8)))))
 552
 553 (define-compiler-macro prim-size (&whole form val type tag)
 554   (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 555                      :fixed32 :sfixed32 :fixed64 :sfixed64
 556                      :string :bytes :bool :float :double))
 557     `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 558        ,(ecase type
 559           ((:int32 :uint32)
 560            `(i+ (length32 ,tag) (length32 ,val)))
 561           ((:int64 :uint64)
 562            `(i+ (length32 ,tag) (length64 ,val)))
 563           ((:sint32)
 564            `(i+ (length32 ,tag) (length32 (zig-zag-encode32 ,val))))
 565           ((:sint64)
 566            `(i+ (length32 ,tag) (length64 (zig-zag-encode64 ,val))))
 567           ((:fixed32 :sfixed32)
 568            `(i+ (length32 ,tag) 4))
 569           ((:fixed64 :sfixed64)
 570            `(i+ (length32 ,tag) 8))
 571           ((:string)
 572            `(let ((len (babel:string-size-in-octets ,val :encoding :utf-8)))
 573               (i+ (length32 ,tag) (length32 len) len)))
 574           ((:bytes)
 575            `(let ((len (length ,val)))
 576               (i+ (length32 ,tag) (length32 len) len)))
 577           ((:bool)
 578            `(i+ (length32 ,tag) 1))
 579           ((:float)
 580            `(i+ (length32 ,tag) 4))
 581           ((:double)
 582            `(i+ (length32 ,tag) 8))))
 583     form))
 584
 585 (defun packed-size (values type tag)
 586   "Returns the size in bytes that the packed object will take when serialized.
 587    Watch out, this function turns off most type checking."
 588   (declare (type (unsigned-byte 32) tag))
 589   (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 590     (let ((len (let ((len 0))
 591                  (declare (type fixnum len))
 592                  (dolist (val values len)
 593                    (iincf len (ecase type
 594                                 ((:int32 :uint32) (length32 val))
 595                                 ((:int64 :uint64) (length64 val))
 596                                 ((:sint32) (length32 (zig-zag-encode32 val)))
 597                                 ((:sint64) (length64 (zig-zag-encode64 val)))
 598                                 ((:fixed32 :sfixed32) 4)
 599                                 ((:fixed64 :sfixed64) 8)
 600                                 ((:float) 4)
 601                                 ((:double) 8)))))))
 602       (declare (type (unsigned-byte 32) len))
 603       ;; Two value: the full size of the packed object, and the size
 604       ;; of just the payload
 605       (values (i+ (length32 tag) (length32 len) len) len))))
 606
 607 (define-compiler-macro packed-size (&whole form values type tag)
 608   (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 609                      :fixed32 :sfixed32 :fixed64 :sfixed64
 610                      :float :double))
 611     `(locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 612        (let ((len (let ((len 0))
 613                     (declare (type fixnum len))
 614                     (dolist (val ,values len)
 615                       (iincf len ,(ecase type
 616                                     ((:int32 :uint32) `(length32 val))
 617                                     ((:int64 :uint64) `(length64 val))
 618                                     ((:sint32) `(length32 (zig-zag-encode32 val)))
 619                                     ((:sint64) `(length64 (zig-zag-encode64 val)))
 620                                     ((:fixed32 :sfixed32) `4)
 621                                     ((:fixed64 :sfixed64) `8)
 622                                     ((:float) `4)
 623                                     ((:double) `8)))))))
 624          (declare (type (unsigned-byte 32) len))
 625          (values (i+ (length32 (the (unsigned-byte 32) ,tag)) (length32 len) len) len)))
 626     form))
 627
 628 (defun enum-size (val values tag)
 629   "Returns the size in bytes that the enum object will take when serialized."
 630   (declare (type (unsigned-byte 32) tag))
 631   (let ((idx (let ((e (find val values :key #'proto-value)))
 632                (and e (proto-index e)))))
 633     (assert idx () "There is no enum value for ~S" val)
 634     (i+ (length32 tag) (length32 idx))))
 635
 636
 637 ;;; Raw encoders
 638 ;;; These are called at the lowest level, so arg types are assumed to be correct
 639
 640 (defun encode-uint32 (val buffer index)
 641   "Encodes the unsigned 32-bit integer 'val' as a varint into the buffer
 642    at the given index.
 643    Modifies the buffer, and returns the new index into the buffer.
 644    Watch out, this function turns off all type checking and array bounds checking."
 645   (declare (optimize (speed 3) (safety 0) (debug 0)))
 646   (declare (type (unsigned-byte 32) val)
 647            (type (simple-array (unsigned-byte 8)) buffer)
 648            (type fixnum index))
 649   ;; Seven bits at a time, least significant bits first
 650   (loop do (let ((bits (ildb (byte 7 0) val)))
 651              (declare (type (unsigned-byte 8) bits))
 652              (setq val (iash val -7))
 653              (setf (aref buffer index) (ilogior bits (if (i= val 0) 0 128)))
 654              (iincf index))
 655         until (i= val 0))
 656   (values index buffer))                        ;return the buffer to improve 'trace'
 657
 658 (defun encode-uint64 (val buffer index)
 659   "Encodes the unsigned 64-bit integer 'val' as a varint into the buffer
 660    at the given index.
 661    Modifies the buffer, and returns the new index into the buffer.
 662    Watch out, this function turns off all type checking and array bounds checking."
 663   (declare (optimize (speed 3) (safety 0) (debug 0)))
 664   (declare (type (unsigned-byte 64) val)
 665            (type (simple-array (unsigned-byte 8)) buffer)
 666            (type fixnum index))
 667   (loop do (let ((bits (ldb (byte 7 0) val)))
 668              (declare (type (unsigned-byte 8) bits))
 669              (setq val (ash val -7))
 670              (setf (aref buffer index) (ilogior bits (if (zerop val) 0 128)))
 671              (iincf index))
 672         until (zerop val))
 673   (values index buffer))
 674
 675 (defun encode-fixed32 (val buffer index)
 676   "Encodes the unsigned 32-bit integer 'val' as a fixed int into the buffer
 677    at the given index.
 678    Modifies the buffer, and returns the new index into the buffer.
 679    Watch out, this function turns off all type checking and array bounds checking."
 680   (declare (optimize (speed 3) (safety 0) (debug 0)))
 681   (declare (type (unsigned-byte 32) val)
 682            (type (simple-array (unsigned-byte 8)) buffer)
 683            (type fixnum index))
 684   (loop repeat 4 doing
 685     (let ((byte (ildb (byte 8 0) val)))
 686       (declare (type (unsigned-byte 8) byte))
 687       (setq val (iash val -8))
 688       (setf (aref buffer index) byte)
 689       (iincf index)))
 690   (values index buffer))
 691
 692 (defun encode-fixed64 (val buffer index)
 693   "Encodes the unsigned 64-bit integer 'val' as a fixed int into the buffer
 694    at the given index.
 695    Modifies the buffer, and returns the new index into the buffer.
 696    Watch out, this function turns off all type checking and array bounds checking."
 697   (declare (optimize (speed 3) (safety 0) (debug 0)))
 698   (declare (type (unsigned-byte 64) val)
 699            (type (simple-array (unsigned-byte 8)) buffer)
 700            (type fixnum index))
 701   (loop repeat 8 doing
 702     (let ((byte (ldb (byte 8 0) val)))
 703       (declare (type (unsigned-byte 8) byte))
 704       (setq val (ash val -8))
 705       (setf (aref buffer index) byte)
 706       (iincf index)))
 707   (values index buffer))
 708
 709 (defun encode-sfixed32 (val buffer index)
 710   "Encodes the signed 32-bit integer 'val' as a fixed int into the buffer
 711    at the given index.
 712    Modifies the buffer, and returns the new index into the buffer.
 713    Watch out, this function turns off all type checking and array bounds checking."
 714   (declare (optimize (speed 3) (safety 0) (debug 0)))
 715   (declare (type (signed-byte 32) val)
 716            (type (simple-array (unsigned-byte 8)) buffer)
 717            (type fixnum index))
 718   (loop repeat 4 doing
 719     (let ((byte (ildb (byte 8 0) val)))
 720       (declare (type (unsigned-byte 8) byte))
 721       (setq val (iash val -8))
 722       (setf (aref buffer index) byte)
 723       (iincf index)))
 724   (values index buffer))
 725
 726 (defun encode-sfixed64 (val buffer index)
 727   "Encodes the signed 64-bit integer 'val' as a fixed int into the buffer
 728    at the given index.
 729    Modifies the buffer, and returns the new index into the buffer.
 730    Watch out, this function turns off all type checking and array bounds checking."
 731   (declare (optimize (speed 3) (safety 0) (debug 0)))
 732   (declare (type (signed-byte 64) val)
 733            (type (simple-array (unsigned-byte 8)) buffer)
 734            (type fixnum index))
 735   (loop repeat 8 doing
 736     (let ((byte (ldb (byte 8 0) val)))
 737       (declare (type (unsigned-byte 8) byte))
 738       (setq val (ash val -8))
 739       (setf (aref buffer index) byte)
 740       (iincf index)))
 741   (values index buffer))
 742
 743 (defun encode-single (val buffer index)
 744   "Encodes the single float 'val' into the buffer at the given index.
 745    Modifies the buffer, and returns the new index into the buffer.
 746    Watch out, this function turns off all type checking and array bounds checking."
 747   (declare (optimize (speed 3) (safety 0) (debug 0)))
 748   (declare (type single-float val)
 749            (type (simple-array (unsigned-byte 8)) buffer)
 750            (type fixnum index))
 751   (let ((bits (single-float-bits val)))
 752     (loop repeat 4 doing
 753       (let ((byte (ldb (byte 8 0) bits)))
 754         (declare (type (unsigned-byte 8) byte))
 755         (setq bits (ash bits -8))
 756         (setf (aref buffer index) byte)
 757         (iincf index))))
 758   (values index buffer))
 759
 760 (defun encode-double (val buffer index)
 761   "Encodes the double float 'val' into the buffer at the given index.
 762    Modifies the buffer, and returns the new index into the buffer.
 763    Watch out, this function turns off all type checking and array bounds checking."
 764   (declare (optimize (speed 3) (safety 0) (debug 0)))
 765   (declare (type double-float val)
 766            (type (simple-array (unsigned-byte 8)) buffer)
 767            (type fixnum index))
 768   (multiple-value-bind (low high)
 769       (double-float-bits val)
 770     (loop repeat 4 doing
 771       (let ((byte (ldb (byte 8 0) low)))
 772         (declare (type (unsigned-byte 8) byte))
 773         (setq low (ash low -8))
 774         (setf (aref buffer index) byte)
 775         (iincf index)))
 776     (loop repeat 4 doing
 777       (let ((byte (ldb (byte 8 0) high)))
 778         (declare (type (unsigned-byte 8) byte))
 779         (setq high (ash high -8))
 780         (setf (aref buffer index) byte)
 781         (iincf index))))
 782   (values index buffer))
 783
 784 (defun encode-string (string buffer index)
 785   "Encodes the octets into the buffer at the given index.
 786    Modifies the buffer, and returns the new index into the buffer.
 787    Watch out, this function turns off all type checking and array bounds checking."
 788   (declare (optimize (speed 3) (safety 0) (debug 0)))
 789   (declare (type (simple-array (unsigned-byte 8)) buffer)
 790            (type fixnum index))
 791   (let* ((octets (babel:string-to-octets string :encoding :utf-8))
 792          (len (length octets))
 793          (idx (encode-uint32 len buffer index)))
 794     (declare (type fixnum len)
 795              (type (unsigned-byte 32) idx))
 796     (replace buffer octets :start1 idx)
 797     (values (i+ idx len) buffer)))
 798
 799 (defun encode-octets (octets buffer index)
 800   "Encodes the octets into the buffer at the given index.
 801    Modifies the buffer, and returns the new index into the buffer.
 802    Watch out, this function turns off all type checking and array bounds checking."
 803   (declare (optimize (speed 3) (safety 0) (debug 0)))
 804   (declare (type (simple-array (unsigned-byte 8)) buffer)
 805            (type fixnum index))
 806   (let* ((len (length octets))
 807          (idx (encode-uint32 len buffer index)))
 808     (declare (type fixnum len)
 809              (type (unsigned-byte 32) idx))
 810     (replace buffer octets :start1 idx)
 811     (values (i+ idx len) buffer)))
 812
 813
 814 ;;; Raw decoders
 815 ;;; These are called at the lowest level, so arg types are assumed to be correct
 816
 817 ;; Decode the value from the buffer at the given index,
 818 ;; then return the value and new index into the buffer
 819 (defun decode-uint32 (buffer index)
 820   "Decodes the next 32-bit varint integer in the buffer at the given index.
 821    Returns both the decoded value and the new index into the buffer.
 822    Watch out, this function turns off all type checking and array bounds checking."
 823   (declare (optimize (speed 3) (safety 0) (debug 0)))
 824   (declare (type (simple-array (unsigned-byte 8)) buffer)
 825            (type fixnum index))
 826   ;; Seven bits at a time, least significant bits first
 827   (loop with val fixnum = 0
 828         for places fixnum upfrom 0 by 7
 829         for byte fixnum = (prog1 (aref buffer index) (iincf index))
 830         do (setq val (ilogior val (iash (ildb (byte 7 0) byte) places)))
 831         until (i< byte 128)
 832         finally (progn
 833                   (assert (< val #.(ash 1 32)) ()
 834                           "The value ~D is longer than 32 bits" val)
 835                   (return (values val index)))))
 836
 837 (defun decode-uint64 (buffer index)
 838   "Decodes the next 64-bit varint integer in the buffer at the given index.
 839    Returns both the decoded value and the new index into the buffer.
 840    Watch out, this function turns off all type checking and array bounds checking."
 841   (declare (optimize (speed 3) (safety 0) (debug 0)))
 842   (declare (type (simple-array (unsigned-byte 8)) buffer)
 843            (type fixnum index))
 844   ;; Seven bits at a time, least significant bits first
 845   (loop with val = 0
 846         for places fixnum upfrom 0 by 7
 847         for byte fixnum = (prog1 (aref buffer index) (iincf index))
 848         do (setq val (logior val (ash (ildb (byte 7 0) byte) places)))
 849         until (i< byte 128)
 850         finally (return (values val index))))
 851
 852 (defun decode-fixed32 (buffer index)
 853   "Decodes the next 32-bit unsigned fixed integer in the buffer at the given index.
 854    Returns both the decoded value and the new index into the buffer.
 855    Watch out, this function turns off all type checking and array bounds checking."
 856   (declare (optimize (speed 3) (safety 0) (debug 0)))
 857   (declare (type (simple-array (unsigned-byte 8)) buffer)
 858            (type fixnum index))
 859   ;; Eight bits at a time, least significant bits first
 860   (let ((val 0))
 861     (declare (type fixnum val))
 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 val (ilogior val (iash byte places))))
 866     (values val index)))
 867
 868 (defun decode-sfixed32 (buffer index)
 869   "Decodes the next 32-bit signed fixed integer in the buffer at the given index.
 870    Returns both the decoded value and the new index into the buffer.
 871    Watch out, this function turns off all type checking and array bounds checking."
 872   (declare (optimize (speed 3) (safety 0) (debug 0)))
 873   (declare (type (simple-array (unsigned-byte 8)) buffer)
 874            (type fixnum index))
 875   ;; Eight bits at a time, least significant bits first
 876   (let ((val 0))
 877     (declare (type fixnum val))
 878     (loop repeat 4
 879           for places fixnum upfrom 0 by 8
 880           for byte fixnum = (prog1 (aref buffer index) (iincf index))
 881           do (setq val (ilogior val (iash byte places))))
 882     (when (i= (ldb (byte 1 31) val) 1)              ;sign bit set, so negative value
 883       (decf val #.(ash 1 32)))
 884     (values val index)))
 885
 886 (defun decode-fixed64 (buffer index)
 887   "Decodes the next unsigned 64-bit fixed integer in the buffer at the given index.
 888    Returns both the decoded value and the new index into the buffer.
 889    Watch out, this function turns off all type checking and array bounds checking."
 890   (declare (optimize (speed 3) (safety 0) (debug 0)))
 891   (declare (type (simple-array (unsigned-byte 8)) buffer)
 892            (type fixnum index))
 893   ;; Eight bits at a time, least significant bits first
 894   (let ((val 0))
 895     (loop repeat 8
 896           for places fixnum upfrom 0 by 8
 897           for byte fixnum = (prog1 (aref buffer index) (iincf index))
 898           do (setq val (logior val (ash byte places))))
 899     (values val index)))
 900
 901 (defun decode-sfixed64 (buffer index)
 902   "Decodes the next signed 64-bit fixed integer in the buffer at the given index.
 903    Returns both the decoded value and the new index into the buffer.
 904    Watch out, this function turns off all type checking and array bounds checking."
 905   (declare (optimize (speed 3) (safety 0) (debug 0)))
 906   (declare (type (simple-array (unsigned-byte 8)) buffer)
 907            (type fixnum index))
 908   ;; Eight bits at a time, least significant bits first
 909   (let ((val 0))
 910     (loop repeat 8
 911           for places fixnum upfrom 0 by 8
 912           for byte fixnum = (prog1 (aref buffer index) (iincf index))
 913           do (setq val (logior val (ash byte places))))
 914     (when (i= (ldb (byte 1 63) val) 1)             ;sign bit set, so negative value
 915       (decf val #.(ash 1 64)))
 916     (values val index)))
 917
 918 (defun decode-single (buffer index)
 919   "Decodes the next single float in the buffer at the given index.
 920    Returns both the decoded value and the new index into the buffer.
 921    Watch out, this function turns off all type checking and array bounds checking."
 922   (declare (optimize (speed 3) (safety 0) (debug 0)))
 923   (declare (type (simple-array (unsigned-byte 8)) buffer)
 924            (type fixnum index))
 925   ;; Eight bits at a time, least significant bits first
 926   (let ((bits 0))
 927     (loop repeat 4
 928           for places fixnum upfrom 0 by 8
 929           for byte fixnum = (prog1 (aref buffer index) (iincf index))
 930           do (setq bits (logior bits (ash byte places))))
 931     (when (i= (ldb (byte 1 31) bits) 1)             ;sign bit set, so negative value
 932       (decf bits #.(ash 1 32)))
 933     (values (make-single-float bits) index)))
 934
 935 (defun decode-double (buffer index)
 936   "Decodes the next double float in the buffer at the given index.
 937    Returns both the decoded value and the new index into the buffer.
 938    Watch out, this function turns off all type checking and array bounds checking."
 939   (declare (optimize (speed 3) (safety 0) (debug 0)))
 940   (declare (type (simple-array (unsigned-byte 8)) buffer)
 941            (type fixnum index))
 942   ;; Eight bits at a time, least significant bits first
 943   (let ((low  0)
 944         (high 0))
 945     (loop repeat 4
 946           for places fixnum upfrom 0 by 8
 947           for byte fixnum = (prog1 (aref buffer index) (iincf index))
 948           do (setq low (logior low (ash byte places))))
 949     (loop repeat 4
 950           for places fixnum upfrom 0 by 8
 951           for byte fixnum = (prog1 (aref buffer index) (iincf index))
 952           do (setq high (logior high (ash byte places))))
 953     ;; High bits are signed, but low bits are unsigned
 954     (when (i= (ldb (byte 1 31) high) 1)             ;sign bit set, so negative value
 955       (decf high #.(ash 1 32)))
 956     (values (make-double-float low high) index)))
 957
 958 (defun decode-string (buffer index)
 959   "Decodes the next UTF-8 encoded string in the buffer at the given index.
 960    Returns both the decoded string and the new index into the buffer.
 961    Watch out, this function turns off all type checking and array bounds checking."
 962   (declare (optimize (speed 3) (safety 0) (debug 0)))
 963   (declare (type (simple-array (unsigned-byte 8)) buffer)
 964            (type fixnum index))
 965   (multiple-value-bind (len idx)
 966       (decode-uint32 buffer index)
 967     (declare (type (unsigned-byte 32) len)
 968              (type fixnum idx))
 969     (values (babel:octets-to-string buffer :start idx :end (i+ idx len) :encoding :utf-8) (i+ idx len))))
 970
 971 (defun decode-octets (buffer index)
 972   "Decodes the next octets in the buffer at the given index.
 973    Returns both the decoded value and the new index into the buffer.
 974    Watch out, this function turns off all type checking and array bounds checking."
 975   (declare (optimize (speed 3) (safety 0) (debug 0)))
 976   (declare (type (simple-array (unsigned-byte 8)) buffer)
 977            (type fixnum index))
 978   (multiple-value-bind (len idx)
 979       (decode-uint32 buffer index)
 980     (declare (type (unsigned-byte 32) len)
 981              (type fixnum idx))
 982     (values (subseq buffer idx (i+ idx len)) (i+ idx len))))
 983
 984
 985 ;;; Raw lengths
 986 ;;; These are called at the lowest level, so arg types are assumed to be correct
 987
 988 (defun length32 (val)
 989   "Returns the length that 'val' will take when encoded as a 32-bit integer."
 990   (declare (optimize (speed 3) (safety 0) (debug 0)))
 991   (declare (type (unsigned-byte 32) val))
 992   (let ((size 0))
 993     (declare (type fixnum size))
 994     (loop do (progn
 995                (setq val (iash val -7))
 996                (iincf size))
 997           until (i= val 0))
 998     size))
 999
1000 (defun length64 (val)
1001   "Returns the length that 'val' will take when encoded as a 64-bit integer."
1002   (declare (optimize (speed 3) (safety 0) (debug 0)))
1003   (declare (type (unsigned-byte 64) val))
1004   (let ((size 0))
1005     (declare (type fixnum size))
1006     (loop do (progn
1007                (setq val (ash val -7))
1008                (iincf size))
1009           until (zerop val))
1010     size))
1011
1012
1013 ;;; Skipping elements
1014 ;;; This is called at the lowest level, so arg types are assumed to be correct
1015
1016 (defun skip-element (buffer index tag)
1017   "Skip an element in the buffer at the index of the given wire type.
1018    Returns the new index in the buffer.
1019    Watch out, this function turns off all type checking and all array bounds checking."
1020   (declare (optimize (speed 3) (safety 0) (debug 0)))
1021   (declare (type (simple-array (unsigned-byte 8)) buffer)
1022            (type fixnum index)
1023            (type (unsigned-byte 32) tag))
1024   (case (ilogand tag #x7)
1025     ((#.$wire-type-varint)
1026      (loop for byte fixnum = (prog1 (aref buffer index) (iincf index))
1027            until (i< byte 128))
1028      index)
1029     ((#.$wire-type-string)
1030      (multiple-value-bind (len idx)
1031          (decode-uint32 buffer index)
1032        (declare (type (unsigned-byte 32) len)
1033                 (type fixnum idx))
1034        (i+ idx len)))
1035     ((#.$wire-type-32bit)
1036      (i+ index 4))
1037     ((#.$wire-type-64bit)
1038      (i+ index 8))
1039     ((#.$wire-type-start-group)
1040      (loop (multiple-value-bind (new-tag idx)
1041                (decode-uint32 buffer index)
1042              (cond ((not (i= (ilogand new-tag #x7) $wire-type-end-group))
1043                     ;; If it's not the end of a group, skip the next element
1044                     (setq index (skip-element buffer idx new-tag)))
1045                    ;; If it's the end of the expected group, we're done
1046                    ((i= (i- tag $wire-type-start-group) (i- new-tag $wire-type-end-group))
1047                     (return idx))
1048                    (t
1049                     (assert (i= (i- tag $wire-type-start-group) (i- new-tag $wire-type-end-group)) ()
1050                             "Couldn't find a matching end group tag"))))))
1051     (t index)))