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