wire-format.lisp

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