wire-format.lisp

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