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 &optional vectorp)
 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 (ignore vectorp)
 244            (type (simple-array (unsigned-byte 8)) buffer)
 245            (type (unsigned-byte 32) tag)
 246            (type fixnum index))
 247   (locally (declare #.$optimize-serialization)
 248     (let ((idx (encode-uint32 tag buffer index)))
 249       (declare (type fixnum idx))
 250       (multiple-value-bind (full-len len)
 251           (packed-size values type tag)
 252         (declare (type fixnum len) (ignore full-len))
 253         (setq idx (encode-uint32 len buffer idx)))
 254       (ecase type
 255         ((:int32 :uint32)
 256          (map () #'(lambda (val) (setq idx (encode-uint32 (ldb (byte 32 0) val) buffer idx))) values))
 257         ((:int64 :uint64)
 258          (map () #'(lambda (val) (setq idx (encode-uint64 (ldb (byte 64 0) val) buffer idx))) values))
 259         ((:sint32)
 260          (map () #'(lambda (val) (setq idx (encode-uint32 (zig-zag-encode32 val) buffer idx))) values))
 261         ((:sint64)
 262          (map () #'(lambda (val) (setq idx (encode-uint64 (zig-zag-encode64 val) buffer idx))) values))
 263         ((:fixed32)
 264          (map () #'(lambda (val) (setq idx (encode-fixed32 val buffer idx))) values))
 265         ((:sfixed32)
 266          (map () #'(lambda (val) (setq idx (encode-sfixed32 val buffer idx))) values))
 267         ((:fixed64)
 268          (map () #'(lambda (val) (setq idx (encode-fixed64 val buffer idx))) values))
 269         ((:sfixed64)
 270          (map () #'(lambda (val) (setq idx (encode-sfixed64 val buffer idx))) values))
 271         ((:bool)
 272          (map () #'(lambda (val) (setq idx (encode-uint32 (if val 1 0) buffer idx))) values))
 273         ((:float)
 274          (map () #'(lambda (val) (setq idx (encode-single val buffer idx))) values))
 275         ((:double)
 276          (map () #'(lambda (val) (setq idx (encode-double val buffer idx))) values)))
 277       idx)))
 278
 279 ;; The optimized serializers supply 'vectorp' so we can generate better code
 280 (define-compiler-macro serialize-packed (&whole form values type tag buffer index
 281                                          &optional (vectorp nil vectorp-p))
 282   (setq type (fold-symbol type)
 283         tag  (fold-symbol tag))
 284   (if (and vectorp-p
 285            `(member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 286                            :fixed32 :sfixed32 :fixed64 :sfixed64
 287                            :bool :float :double)))
 288     `(locally (declare #.$optimize-serialization
 289                        (type (simple-array (unsigned-byte 8)) ,buffer)
 290                        ;; 'tag' is a constant, no need to declare its type
 291                        (type fixnum ,index))
 292        (let ((idx (encode-uint32 ,tag ,buffer ,index)))
 293          (declare (type fixnum idx))
 294          (multiple-value-bind (full-len len)
 295              (packed-size ,values ,type ,tag)
 296            (declare (type fixnum len) (ignore full-len))
 297            (setq idx (encode-uint32 len ,buffer idx)))
 298          (,(if vectorp 'dovector 'dolist) (val ,values)
 299             ,(ecase type
 300                ((:int32)
 301                 `(setq idx (encode-uint32 (ldb (byte 32 0) val) ,buffer idx)))
 302                ((:int64)
 303                 `(setq idx (encode-uint64 (ldb (byte 64 0) val) ,buffer idx)))
 304                ((:uint32)
 305                 `(setq idx (encode-uint32 val ,buffer idx)))
 306                ((:uint64)
 307                 `(setq idx (encode-uint64 val ,buffer idx)))
 308                ((:sint32)
 309                 `(setq idx (encode-uint32 (zig-zag-encode32 val) ,buffer idx)))
 310                ((:sint64)
 311                 `(setq idx (encode-uint64 (zig-zag-encode64 val) ,buffer idx)))
 312                ((:fixed32)
 313                 `(setq idx (encode-fixed32 val ,buffer idx)))
 314                ((:sfixed32)
 315                 `(setq idx (encode-sfixed32 val ,buffer idx)))
 316                ((:fixed64)
 317                 `(setq idx (encode-fixed64 val ,buffer idx)))
 318                ((:sfixed64)
 319                 `(setq idx (encode-sfixed64 val ,buffer idx)))
 320                ((:bool)
 321                 `(setq idx (encode-uint32 (if val 1 0) ,buffer idx)))
 322                ((:float)
 323                 `(setq idx (encode-single val ,buffer idx)))
 324                ((:double)
 325                 `(setq idx (encode-double val ,buffer idx)))))
 326          idx))
 327     form))
 328
 329 (defun serialize-enum (val enum-values tag buffer index)
 330   "Serializes a Protobufs enum value into the buffer at the given index.
 331    The value is given by 'val', the enum values are in 'enum-values'.
 332    Modifies the buffer in place, and returns the new index into the buffer.
 333    Watch out, this function turns off most type checking and all array bounds checking."
 334   (declare (type list enum-values)
 335            (type (simple-array (unsigned-byte 8)) buffer)
 336            (type (unsigned-byte 32) tag)
 337            (type fixnum index))
 338   (locally (declare #.$optimize-serialization)
 339     (let* ((val (let ((e (find val enum-values :key #'proto-value)))
 340                   (and e (proto-index e))))
 341            (idx (encode-uint32 tag buffer index)))
 342       (declare (type (unsigned-byte 32) val)
 343                (type fixnum idx))
 344       (encode-uint32 (ldb (byte 32 0) val) buffer idx))))
 345
 346 (defun serialize-packed-enum (values enum-values tag buffer index)
 347   "Serializes Protobufs enum values into the buffer at the given index.
 348    The values are given by 'values', the enum values are in 'enum-values'.
 349    Modifies the buffer in place, and returns the new index into the buffer.
 350    Watch out, this function turns off most type checking and all array bounds checking."
 351   (declare (type list enum-values)
 352            (type (simple-array (unsigned-byte 8)) buffer)
 353            (type (unsigned-byte 32) tag)
 354            (type fixnum index))
 355   (locally (declare #.$optimize-serialization)
 356     (let ((idx (encode-uint32 tag buffer index)))
 357       (declare (type fixnum idx))
 358       (multiple-value-bind (full-len len)
 359           (packed-enum-size values enum-values tag)
 360         (declare (type fixnum len) (ignore full-len))
 361         (setq idx (encode-uint32 len buffer idx)))
 362       (map () #'(lambda (val)
 363                   (let ((val (let ((e (find val enum-values :key #'proto-value)))
 364                                (and e (proto-index e)))))
 365                     (declare (type (unsigned-byte 32) val))
 366                     (setq idx (encode-uint32 (ldb (byte 32 0) val) buffer idx)))) values)
 367       idx)))
 368
 369
 370 ;;; Deserializers
 371
 372 ;; Deserialize the next object of type 'type'
 373 (defun deserialize-prim (type buffer index)
 374   "Deserializes the next object of primitive type 'type'.
 375    Deserializes from the byte vector 'buffer' starting at 'index'.
 376    Returns the value and and the new index into the buffer.
 377    Watch out, this function turns off most type checking and all array bounds checking."
 378   (declare (type (simple-array (unsigned-byte 8)) buffer)
 379            (type fixnum index))
 380   (locally (declare #.$optimize-serialization)
 381     (ecase type
 382       ((:int32)
 383        (decode-int32 buffer index))
 384       ((:int64)
 385        (decode-int64 buffer index))
 386       ((:uint32)
 387        (decode-uint32 buffer index))
 388       ((:uint64)
 389        (decode-uint64 buffer index))
 390       ((:sint32)
 391        (multiple-value-bind (val idx)
 392            (decode-uint32 buffer index)
 393          (values (zig-zag-decode32 val) idx)))
 394       ((:sint64)
 395        (multiple-value-bind (val idx)
 396            (decode-uint64 buffer index)
 397          (values (zig-zag-decode64 val) idx)))
 398       ((:fixed32)
 399        (decode-fixed32 buffer index))
 400       ((:sfixed32)
 401        (decode-sfixed32 buffer index))
 402       ((:fixed64)
 403        (decode-fixed64 buffer index))
 404       ((:sfixed64)
 405        (decode-sfixed64 buffer index))
 406       ((:string)
 407        (decode-string buffer index))
 408       ((:bytes)
 409        (decode-octets buffer index))
 410       ((:bool)
 411        (multiple-value-bind (val idx)
 412            (decode-uint32 buffer index)
 413          (values (if (i= val 0) nil t) idx)))
 414       ((:float)
 415        (decode-single buffer index))
 416       ((:double)
 417        (decode-double buffer index))
 418       ;; A few of our homegrown types
 419       ((:symbol)
 420        ;; Note that this is consy, avoid it if possible
 421        (multiple-value-bind (val idx)
 422            (decode-string buffer index)
 423          (values (make-lisp-symbol val) idx)))
 424       ((:date :time :datetime :timestamp)
 425        (decode-uint64 buffer index)))))
 426
 427 (define-compiler-macro deserialize-prim (&whole form type buffer index)
 428   (setq type (fold-symbol type))
 429   (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 430                      :fixed32 :sfixed32 :fixed64 :sfixed64
 431                      :string :bytes :bool :float :double))
 432     `(locally (declare #.$optimize-serialization
 433                        (type (simple-array (unsigned-byte 8)) ,buffer)
 434                        (type fixnum ,index))
 435        ,(ecase type
 436           ((:int32)
 437            `(decode-int32 ,buffer ,index))
 438           ((:int64)
 439            `(decode-int64 ,buffer ,index))
 440           ((:uint32)
 441            `(decode-uint32 ,buffer ,index))
 442           ((:uint64)
 443            `(decode-uint64 ,buffer ,index))
 444           ((:sint32)
 445            `(multiple-value-bind (val idx)
 446                 (decode-uint32 ,buffer ,index)
 447               (values (zig-zag-decode32 val) idx)))
 448           ((:sint64)
 449            `(multiple-value-bind (val idx)
 450                (decode-uint64 ,buffer ,index)
 451              (values (zig-zag-decode64 val) idx)))
 452           ((:fixed32)
 453            `(decode-fixed32 ,buffer ,index))
 454           ((:sfixed32)
 455            `(decode-sfixed32 ,buffer ,index))
 456           ((:fixed64)
 457            `(decode-fixed64 ,buffer ,index))
 458           ((:sfixed64)
 459            `(decode-sfixed64 ,buffer ,index))
 460           ((:string)
 461            `(decode-string ,buffer ,index))
 462           ((:bytes)
 463            `(decode-octets ,buffer ,index))
 464           ((:bool)
 465            `(multiple-value-bind (val idx)
 466                 (decode-uint32 ,buffer ,index)
 467               (values (if (i= val 0) nil t) idx)))
 468           ((:float)
 469            `(decode-single ,buffer ,index))
 470           ((:double)
 471            `(decode-double ,buffer ,index))))
 472     form))
 473
 474 (defun deserialize-packed (type buffer index)
 475   "Deserializes the next packed values of type 'type'.
 476    Deserializes from the byte vector 'buffer' starting at 'index'.
 477    Returns the value and and the new index into the buffer.
 478    Watch out, this function turns off most type checking and all array bounds checking."
 479   (declare (type (simple-array (unsigned-byte 8)) buffer)
 480            (type fixnum index))
 481   (locally (declare #.$optimize-serialization)
 482     (multiple-value-bind (len idx)
 483         (decode-uint32 buffer index)
 484       (declare (type (unsigned-byte 32) len)
 485                (type fixnum idx))
 486       (let ((end (i+ idx len)))
 487         (declare (type (unsigned-byte 32) end))
 488         (with-collectors ((values collect-value))
 489           (loop
 490             (when (>= idx end)
 491               (return-from deserialize-packed (values values idx)))
 492             (multiple-value-bind (val nidx)
 493                 (ecase type
 494                   ((:int32)
 495                    (decode-int32 buffer idx))
 496                   ((:int64)
 497                    (decode-int64 buffer idx))
 498                   ((:uint32)
 499                    (decode-uint32 buffer idx))
 500                   ((:uint64)
 501                    (decode-uint64 buffer idx))
 502                   ((:sint32)
 503                    (multiple-value-bind (val nidx)
 504                        (decode-uint32 buffer idx)
 505                      (values (zig-zag-decode32 val) nidx)))
 506                   ((:sint64)
 507                    (multiple-value-bind (val nidx)
 508                        (decode-uint64 buffer idx)
 509                      (values (zig-zag-decode64 val) nidx)))
 510                   ((:fixed32)
 511                    (decode-fixed32 buffer idx))
 512                   ((:sfixed32)
 513                    (decode-sfixed32 buffer idx))
 514                   ((:fixed64)
 515                    (decode-fixed64 buffer idx))
 516                   ((:sfixed64)
 517                    (decode-sfixed64 buffer idx))
 518                   ((:bool)
 519                    (multiple-value-bind (val nidx)
 520                        (decode-uint32 buffer idx)
 521                      (values (if (i= val 0) nil t) nidx)))
 522                   ((:float)
 523                    (decode-single buffer idx))
 524                   ((:double)
 525                    (decode-double buffer idx)))
 526               (collect-value val)
 527               (setq idx nidx))))))))
 528
 529 (define-compiler-macro deserialize-packed (&whole form type buffer index)
 530   (setq type (fold-symbol type))
 531   (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 532                      :fixed32 :sfixed32 :fixed64 :sfixed64
 533                      :bool :float :double))
 534     `(locally (declare #.$optimize-serialization
 535                        (type (simple-array (unsigned-byte 8)) ,buffer)
 536                        (type fixnum ,index))
 537        (block deserialize-packed
 538          (multiple-value-bind (len idx)
 539              (decode-uint32 ,buffer ,index)
 540            (declare (type (unsigned-byte 32) len)
 541                     (type fixnum idx))
 542            (let ((end (i+ idx len)))
 543              (declare (type (unsigned-byte 32) end))
 544              (with-collectors ((values collect-value))
 545                (loop
 546                  (when (>= idx end)
 547                    (return-from deserialize-packed (values values idx)))
 548                  (multiple-value-bind (val nidx)
 549                      ,(ecase type
 550                         ((:int32)
 551                          `(decode-int32 ,buffer idx))
 552                         ((:int64)
 553                          `(decode-int64 ,buffer idx))
 554                         ((:uint32)
 555                          `(decode-uint32 ,buffer idx))
 556                         ((:uint64)
 557                          `(decode-uint64 ,buffer idx))
 558                         ((:sint32)
 559                          `(multiple-value-bind (val nidx)
 560                               (decode-uint32 ,buffer idx)
 561                             (values (zig-zag-decode32 val) nidx)))
 562                         ((:sint64)
 563                          `(multiple-value-bind (val nidx)
 564                               (decode-uint64 ,buffer idx)
 565                             (values (zig-zag-decode64 val) nidx)))
 566                         ((:fixed32)
 567                          `(decode-fixed32 ,buffer idx))
 568                         ((:sfixed32)
 569                          `(decode-sfixed32 ,buffer idx))
 570                         ((:fixed64)
 571                          `(decode-fixed64 ,buffer idx))
 572                         ((:sfixed64)
 573                          `(decode-sfixed64 ,buffer idx))
 574                         ((:bool)
 575                          `(multiple-value-bind (val nidx)
 576                               (decode-uint32 ,buffer idx)
 577                             (values (if (i= val 0) nil t) nidx)))
 578                         ((:float)
 579                          `(decode-single ,buffer idx))
 580                         ((:double)
 581                          `(decode-double ,buffer idx)))
 582                    (collect-value val)
 583                    (setq idx nidx))))))))
 584     form))
 585
 586 (defun deserialize-enum (enum-values buffer index)
 587   "Deserializes the next enum value take from 'enum-values'.
 588    Deserializes from the byte vector 'buffer' starting at 'index'.
 589    Returns the value and and the new index into the buffer.
 590    Watch out, this function turns off most type checking and all array bounds checking."
 591   (declare (type list enum-values)
 592            (type (simple-array (unsigned-byte 8)) buffer)
 593            (type fixnum index))
 594   (locally (declare #.$optimize-serialization)
 595     (multiple-value-bind (val idx)
 596         (decode-int32 buffer index)
 597       (let ((val (let ((e (find val enum-values :key #'proto-index)))
 598                    (and e (proto-value e)))))
 599         (values val idx)))))
 600
 601 (defun deserialize-packed-enum (enum-values buffer index)
 602   "Deserializes the next packed enum values given in 'enum-values'.
 603    Deserializes from the byte vector 'buffer' starting at 'index'.
 604    Returns the value and and the new index into the buffer.
 605    Watch out, this function turns off most type checking and all array bounds checking."
 606   (declare (type list enum-values)
 607            (type (simple-array (unsigned-byte 8)) buffer)
 608            (type fixnum index))
 609   (locally (declare #.$optimize-serialization)
 610     (multiple-value-bind (len idx)
 611         (decode-uint32 buffer index)
 612       (declare (type (unsigned-byte 32) len)
 613                (type fixnum idx))
 614       (let ((end (i+ idx len)))
 615         (declare (type (unsigned-byte 32) end))
 616         (with-collectors ((values collect-value))
 617           (loop
 618             (when (>= idx end)
 619               (return-from deserialize-packed-enum (values values idx)))
 620             (multiple-value-bind (val nidx)
 621                 (decode-int32 buffer idx)
 622               (let ((val (let ((e (find val enum-values :key #'proto-index)))
 623                            (and e (proto-value e)))))
 624                 (collect-value val)
 625                 (setq idx nidx)))))))))
 626
 627
 628 ;;; Object sizing
 629
 630 (defun prim-size (val type tag)
 631   "Returns the size in bytes that the primitive object will take when serialized.
 632    Watch out, this function turns off most type checking."
 633   (declare (type (unsigned-byte 32) tag))
 634   (locally (declare #.$optimize-serialization)
 635     (ecase type
 636       ((:int32 :uint32)
 637        (i+ (length32 tag) (length32 (ldb (byte 32 0) val))))
 638       ((:int64 :uint64)
 639        (i+ (length32 tag) (length64 (ldb (byte 64 0) val))))
 640       ((:sint32)
 641        (i+ (length32 tag) (length32 (zig-zag-encode32 val))))
 642       ((:sint64)
 643        (i+ (length32 tag) (length64 (zig-zag-encode64 val))))
 644       ((:fixed32 :sfixed32)
 645        (i+ (length32 tag) 4))
 646       ((:fixed64 :sfixed64)
 647        (i+ (length32 tag) 8))
 648       ((:string)
 649        (let ((len (babel:string-size-in-octets val :encoding :utf-8)))
 650          (i+ (length32 tag) (length32 len) len)))
 651       ((:bytes)
 652        (let ((len (length val)))
 653          (i+ (length32 tag) (length32 len) len)))
 654       ((:bool)
 655        (i+ (length32 tag) 1))
 656       ((:float)
 657        (i+ (length32 tag) 4))
 658       ((:double)
 659        (i+ (length32 tag) 8))
 660       ;; A few of our homegrown types
 661       ((:symbol)
 662        (let ((len (if (keywordp val)
 663                     (length (symbol-name val))
 664                     (i+ (length (package-name (symbol-package val))) 1 (length (symbol-name val))))))
 665          (i+ (length32 tag) (length32 len) len)))
 666       ((:date :time :datetime :timestamp)
 667        (i+ (length32 tag) 8)))))
 668
 669 (define-compiler-macro prim-size (&whole form val type tag)
 670   (setq type (fold-symbol type)
 671         tag  (fold-symbol tag))
 672   (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 673                      :fixed32 :sfixed32 :fixed64 :sfixed64
 674                      :string :bytes :bool :float :double))
 675     `(locally (declare #.$optimize-serialization)
 676        ,(ecase type
 677           ((:int32)
 678            `(i+ (length32 ,tag) (length32 (ldb (byte 32 0) ,val))))
 679           ((:int64)
 680            `(i+ (length32 ,tag) (length64 (ldb (byte 64 0) ,val))))
 681           ((:uint32)
 682            `(i+ (length32 ,tag) (length32 ,val)))
 683           ((:uint64)
 684            `(i+ (length32 ,tag) (length64 ,val)))
 685           ((:sint32)
 686            `(i+ (length32 ,tag) (length32 (zig-zag-encode32 ,val))))
 687           ((:sint64)
 688            `(i+ (length32 ,tag) (length64 (zig-zag-encode64 ,val))))
 689           ((:fixed32 :sfixed32)
 690            `(i+ (length32 ,tag) 4))
 691           ((:fixed64 :sfixed64)
 692            `(i+ (length32 ,tag) 8))
 693           ((:string)
 694            `(let ((len (babel:string-size-in-octets ,val :encoding :utf-8)))
 695               (i+ (length32 ,tag) (length32 len) len)))
 696           ((:bytes)
 697            `(let ((len (length ,val)))
 698               (i+ (length32 ,tag) (length32 len) len)))
 699           ((:bool)
 700            `(i+ (length32 ,tag) 1))
 701           ((:float)
 702            `(i+ (length32 ,tag) 4))
 703           ((:double)
 704            `(i+ (length32 ,tag) 8))))
 705     form))
 706
 707 (defun packed-size (values type tag &optional vectorp)
 708   "Returns the size in bytes that the packed object will take when serialized.
 709    Watch out, this function turns off most type checking."
 710   (declare (ignore vectorp)
 711            (type (unsigned-byte 32) tag))
 712   (locally (declare #.$optimize-serialization)
 713     (let ((len (let ((len 0))
 714                  (declare (type fixnum len))
 715                  (map () #'(lambda (val)
 716                              (iincf len (ecase type
 717                                           ((:int32 :uint32) (length32 (ldb (byte 32 0) val)))
 718                                           ((:int64 :uint64) (length64 (ldb (byte 64 0) val)))
 719                                           ((:sint32) (length32 (zig-zag-encode32 val)))
 720                                           ((:sint64) (length64 (zig-zag-encode64 val)))
 721                                           ((:fixed32 :sfixed32) 4)
 722                                           ((:fixed64 :sfixed64) 8)
 723                                           ((:bool)   1)
 724                                           ((:float)  4)
 725                                           ((:double) 8)))) values)
 726                  len)))
 727       (declare (type (unsigned-byte 32) len))
 728       ;; Two value: the full size of the packed object, and the size
 729       ;; of just the payload
 730       (values (i+ (length32 tag) (length32 len) len) len))))
 731
 732 ;; The optimized serializers supply 'vectorp' so we can generate better code
 733 (define-compiler-macro packed-size (&whole form values type tag
 734                                     &optional (vectorp nil vectorp-p))
 735   (setq type (fold-symbol type)
 736         tag  (fold-symbol tag))
 737   (if (and vectorp-p
 738            (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
 739                           :fixed32 :sfixed32 :fixed64 :sfixed64
 740                           :bool :float :double)))
 741     `(locally (declare #.$optimize-serialization)
 742        (let ((len (let ((len 0))
 743                     (declare (type fixnum len))
 744                     (,(if vectorp 'dovector 'dolist) (val ,values)
 745                        (iincf len ,(ecase type
 746                                      ((:int32) `(length32 (ldb (byte 32 0) val)))
 747                                      ((:int64) `(length64 (ldb (byte 64 0) val)))
 748                                      ((:uint32) `(length32 val))
 749                                      ((:uint64) `(length64 val))
 750                                      ((:sint32) `(length32 (zig-zag-encode32 val)))
 751                                      ((:sint64) `(length64 (zig-zag-encode64 val)))
 752                                      ((:fixed32 :sfixed32) `4)
 753                                      ((:fixed64 :sfixed64) `8)
 754                                      ((:bool)   `1)
 755                                      ((:float)  `4)
 756                                      ((:double) `8))))
 757                     len)))
 758          (declare (type (unsigned-byte 32) len))
 759          (values (i+ (length32 (the (unsigned-byte 32) ,tag)) (length32 len) len) len)))
 760     form))
 761
 762 (defun enum-size (val enum-values tag)
 763   "Returns the size in bytes that the enum object will take when serialized."
 764   (declare (type list enum-values)
 765            (type (unsigned-byte 32) tag))
 766   (let ((idx (let ((e (find val enum-values :key #'proto-value)))
 767                (and e (proto-index e)))))
 768     (assert idx () "There is no enum value for ~S" val)
 769     (i+ (length32 tag) (length32 (ldb (byte 32 0) idx)))))
 770
 771 (defun packed-enum-size (values enum-values tag)
 772   "Returns the size in bytes that the enum values will take when serialized."
 773   (declare (type list enum-values)
 774            (type (unsigned-byte 32) tag))
 775   (let ((len (let ((len 0))
 776                (declare (type fixnum len))
 777                (map () #'(lambda (val)
 778                            (let ((idx (let ((e (find val enum-values :key #'proto-value)))
 779                                         (and e (proto-index e)))))
 780                              (assert idx () "There is no enum value for ~S" val)
 781                              (iincf len (length32 (ldb (byte 32 0) idx))))) values)
 782                len)))
 783     (declare (type (unsigned-byte 32) len))
 784     ;; Two value: the full size of the packed object, and the size
 785     ;; of just the payload
 786     (values (i+ (length32 tag) (length32 len) len) len)))
 787
 788 \f
 789 ;;; Wire-level encoders
 790 ;;; These are called at the lowest level, so arg types are assumed to be correct
 791
 792 (defun encode-uint32 (val buffer index)
 793   "Encodes the unsigned 32-bit integer 'val' as a varint into the buffer
 794    at the given index.
 795    Modifies the buffer, and returns the new index into the buffer.
 796    Watch out, this function turns off all type checking and array bounds checking."
 797   (declare #.$optimize-serialization)
 798   (declare (type (unsigned-byte 32) val)
 799            (type (simple-array (unsigned-byte 8)) buffer)
 800            (type fixnum index))
 801   ;; Seven bits at a time, least significant bits first
 802   (loop do (let ((bits (ildb (byte 7 0) val)))
 803              (declare (type (unsigned-byte 8) bits))
 804              (setq val (iash val -7))
 805              (setf (aref buffer index) (ilogior bits (if (i= val 0) 0 128)))
 806              (iincf index))
 807         until (i= val 0))
 808   (values index buffer))                        ;return the buffer to improve 'trace'
 809
 810 (defun encode-uint64 (val buffer index)
 811   "Encodes the unsigned 64-bit integer 'val' as a varint into the buffer
 812    at the given index.
 813    Modifies the buffer, and returns the new index into the buffer.
 814    Watch out, this function turns off all type checking and array bounds checking."
 815   (declare #.$optimize-serialization)
 816   (declare (type (unsigned-byte 64) val)
 817            (type (simple-array (unsigned-byte 8)) buffer)
 818            (type fixnum index))
 819   (loop do (let ((bits (ldb (byte 7 0) val)))
 820              (declare (type (unsigned-byte 8) bits))
 821              (setq val (ash val -7))
 822              (setf (aref buffer index) (ilogior bits (if (zerop val) 0 128)))
 823              (iincf index))
 824         until (zerop val))
 825   (values index buffer))
 826
 827 (defun encode-fixed32 (val buffer index)
 828   "Encodes the unsigned 32-bit integer 'val' as a fixed int into the buffer
 829    at the given index.
 830    Modifies the buffer, and returns the new index into the buffer.
 831    Watch out, this function turns off all type checking and array bounds checking."
 832   (declare #.$optimize-serialization)
 833   (declare (type (unsigned-byte 32) val)
 834            (type (simple-array (unsigned-byte 8)) buffer)
 835            (type fixnum index))
 836   (loop repeat 4 doing
 837     (let ((byte (ildb (byte 8 0) val)))
 838       (declare (type (unsigned-byte 8) byte))
 839       (setq val (iash val -8))
 840       (setf (aref buffer index) byte)
 841       (iincf index)))
 842   (values index buffer))
 843
 844 (defun encode-fixed64 (val buffer index)
 845   "Encodes the unsigned 64-bit integer 'val' as a fixed int into the buffer
 846    at the given index.
 847    Modifies the buffer, and returns the new index into the buffer.
 848    Watch out, this function turns off all type checking and array bounds checking."
 849   (declare #.$optimize-serialization)
 850   (declare (type (unsigned-byte 64) val)
 851            (type (simple-array (unsigned-byte 8)) buffer)
 852            (type fixnum index))
 853   (loop repeat 8 doing
 854     (let ((byte (ldb (byte 8 0) val)))
 855       (declare (type (unsigned-byte 8) byte))
 856       (setq val (ash val -8))
 857       (setf (aref buffer index) byte)
 858       (iincf index)))
 859   (values index buffer))
 860
 861 (defun encode-sfixed32 (val buffer index)
 862   "Encodes the signed 32-bit integer 'val' as a fixed int into the buffer
 863    at the given index.
 864    Modifies the buffer, and returns the new index into the buffer.
 865    Watch out, this function turns off all type checking and array bounds checking."
 866   (declare #.$optimize-serialization)
 867   (declare (type (signed-byte 32) val)
 868            (type (simple-array (unsigned-byte 8)) buffer)
 869            (type fixnum index))
 870   (loop repeat 4 doing
 871     (let ((byte (ildb (byte 8 0) val)))
 872       (declare (type (unsigned-byte 8) byte))
 873       (setq val (iash val -8))
 874       (setf (aref buffer index) byte)
 875       (iincf index)))
 876   (values index buffer))
 877
 878 (defun encode-sfixed64 (val buffer index)
 879   "Encodes the signed 64-bit integer 'val' as a fixed int into the buffer
 880    at the given index.
 881    Modifies the buffer, and returns the new index into the buffer.
 882    Watch out, this function turns off all type checking and array bounds checking."
 883   (declare #.$optimize-serialization)
 884   (declare (type (signed-byte 64) val)
 885            (type (simple-array (unsigned-byte 8)) buffer)
 886            (type fixnum index))
 887   (loop repeat 8 doing
 888     (let ((byte (ldb (byte 8 0) val)))
 889       (declare (type (unsigned-byte 8) byte))
 890       (setq val (ash val -8))
 891       (setf (aref buffer index) byte)
 892       (iincf index)))
 893   (values index buffer))
 894
 895 (defun encode-single (val buffer index)
 896   "Encodes the single float 'val' into the buffer at the given index.
 897    Modifies the buffer, and returns the new index into the buffer.
 898    Watch out, this function turns off all type checking and array bounds checking."
 899   (declare #.$optimize-serialization)
 900   (declare (type single-float val)
 901            (type (simple-array (unsigned-byte 8)) buffer)
 902            (type fixnum index))
 903   (let ((bits (single-float-bits val)))
 904     (loop repeat 4 doing
 905       (let ((byte (ldb (byte 8 0) bits)))
 906         (declare (type (unsigned-byte 8) byte))
 907         (setq bits (ash bits -8))
 908         (setf (aref buffer index) byte)
 909         (iincf index))))
 910   (values index buffer))
 911
 912 (defun encode-double (val buffer index)
 913   "Encodes the double float 'val' into the buffer at the given index.
 914    Modifies the buffer, and returns the new index into the buffer.
 915    Watch out, this function turns off all type checking and array bounds checking."
 916   (declare #.$optimize-serialization)
 917   (declare (type double-float val)
 918            (type (simple-array (unsigned-byte 8)) buffer)
 919            (type fixnum index))
 920   (multiple-value-bind (low high)
 921       (double-float-bits val)
 922     (loop repeat 4 doing
 923       (let ((byte (ldb (byte 8 0) low)))
 924         (declare (type (unsigned-byte 8) byte))
 925         (setq low (ash low -8))
 926         (setf (aref buffer index) byte)
 927         (iincf index)))
 928     (loop repeat 4 doing
 929       (let ((byte (ldb (byte 8 0) high)))
 930         (declare (type (unsigned-byte 8) byte))
 931         (setq high (ash high -8))
 932         (setf (aref buffer index) byte)
 933         (iincf index))))
 934   (values index buffer))
 935
 936 (defun encode-string (string buffer index)
 937   "Encodes the octets into the buffer at the given index.
 938    Modifies the buffer, and returns the new index into the buffer.
 939    Watch out, this function turns off all type checking and array bounds checking."
 940   (declare #.$optimize-serialization)
 941   (declare (type (simple-array (unsigned-byte 8)) buffer)
 942            (type fixnum index))
 943   (let* ((octets (babel:string-to-octets string :encoding :utf-8))
 944          (len (length octets))
 945          (idx (encode-uint32 len buffer index)))
 946     (declare (type (array (unsigned-byte 8)) octets)
 947              (type fixnum len)
 948              (type (unsigned-byte 32) idx))
 949     (replace buffer octets :start1 idx)
 950     (values (i+ idx len) buffer)))
 951
 952 (defun encode-octets (octets buffer index)
 953   "Encodes the octets into the buffer at the given index.
 954    Modifies the buffer, and returns the new index into the buffer.
 955    Watch out, this function turns off all type checking and array bounds checking."
 956   (declare #.$optimize-serialization)
 957   (declare (type (array (unsigned-byte 8)) octets)
 958            (type (simple-array (unsigned-byte 8)) buffer)
 959            (type fixnum index))
 960   (let* ((len (length octets))
 961          (idx (encode-uint32 len buffer index)))
 962     (declare (type fixnum len)
 963              (type (unsigned-byte 32) idx))
 964     (replace buffer octets :start1 idx)
 965     (values (i+ idx len) buffer)))
 966
 967
 968 ;;; Wire-level decoders
 969 ;;; These are called at the lowest level, so arg types are assumed to be correct
 970
 971 ;; Decode the value from the buffer at the given index,
 972 ;; then return the value and new index into the buffer
 973 (defun decode-uint32 (buffer index)
 974   "Decodes the next 32-bit varint integer in the buffer at the given index.
 975    Returns both the decoded value and the new index into the buffer.
 976    Watch out, this function turns off all type checking and array bounds checking."
 977   (declare #.$optimize-serialization)
 978   (declare (type (simple-array (unsigned-byte 8)) buffer)
 979            (type fixnum index))
 980   ;; Seven bits at a time, least significant bits first
 981   (let ((val 0))
 982     (declare (type (unsigned-byte 32) val))
 983     (loop for places fixnum upfrom 0 by 7
 984           for byte fixnum = (prog1 (aref buffer index) (iincf index))
 985           do (let ((bits (ildb (byte 7 0) byte)))
 986                (declare (type (unsigned-byte 8) bits))
 987                (setq val (ilogior val (iash bits places))))
 988           until (i< byte 128)
 989           finally (progn
 990                     (assert (< val #.(ash 1 32)) ()
 991                             "The value ~D is longer than 32 bits" val)
 992                     (return (values val index))))))
 993
 994 (defun decode-uint64 (buffer index)
 995   "Decodes the next 64-bit varint integer in the buffer at the given index.
 996    Returns both the decoded value and the new index into the buffer.
 997    Watch out, this function turns off all type checking and array bounds checking."
 998   (declare #.$optimize-serialization)
 999   (declare (type (simple-array (unsigned-byte 8)) buffer)
1000            (type fixnum index))
1001   ;; Seven bits at a time, least significant bits first
1002   (let ((val 0))
1003     (declare (type (unsigned-byte 64) val))
1004     (loop for places fixnum upfrom 0 by 7
1005           for byte fixnum = (prog1 (aref buffer index) (iincf index))
1006           do (let ((bits (ildb (byte 7 0) byte)))
1007                (declare (type (unsigned-byte 8) bits))
1008                (setq val (logior val (ash bits places))))
1009           until (i< byte 128)
1010           finally (return (values val index)))))
1011
1012 (defun decode-int32 (buffer index)
1013   "Decodes the next 32-bit varint integer in the buffer at the given index.
1014    Returns both the decoded value and the new index into the buffer.
1015    Watch out, this function turns off all type checking and array bounds checking."
1016   (declare #.$optimize-serialization)
1017   (declare (type (simple-array (unsigned-byte 8)) buffer)
1018            (type fixnum index))
1019   (multiple-value-bind (val index)
1020       (decode-uint32 buffer index)
1021     (declare (type fixnum val))
1022     (when (i= (ildb (byte 1 31) val) 1)
1023       (idecf val #.(ash 1 32)))
1024     (values val index)))
1025
1026 (defun decode-int64 (buffer index)
1027   "Decodes the next 64-bit varint integer in the buffer at the given index.
1028    Returns both the decoded value and the new index into the buffer.
1029    Watch out, this function turns off all type checking and array bounds checking."
1030   (declare #.$optimize-serialization)
1031   (declare (type (simple-array (unsigned-byte 8)) buffer)
1032            (type fixnum index))
1033   (multiple-value-bind (val index)
1034       (decode-uint64 buffer index)
1035     (when (i= (ldb (byte 1 63 ) val) 1)
1036       (decf val #.(ash 1 64)))
1037     (values val index)))
1038
1039 (defun decode-fixed32 (buffer index)
1040   "Decodes the next 32-bit unsigned fixed integer in the buffer at the given index.
1041    Returns both the decoded value and the new index into the buffer.
1042    Watch out, this function turns off all type checking and array bounds checking."
1043   (declare #.$optimize-serialization)
1044   (declare (type (simple-array (unsigned-byte 8)) buffer)
1045            (type fixnum index))
1046   ;; Eight bits at a time, least significant bits first
1047   (let ((val 0))
1048     (declare (type fixnum val))
1049     (loop repeat 4
1050           for places fixnum upfrom 0 by 8
1051           for byte fixnum = (prog1 (aref buffer index) (iincf index))
1052           do (setq val (ilogior val (iash byte places))))
1053     (values val index)))
1054
1055 (defun decode-fixed64 (buffer index)
1056   "Decodes the next unsigned 64-bit fixed integer in the buffer at the given index.
1057    Returns both the decoded value and the new index into the buffer.
1058    Watch out, this function turns off all type checking and array bounds checking."
1059   (declare #.$optimize-serialization)
1060   (declare (type (simple-array (unsigned-byte 8)) buffer)
1061            (type fixnum index))
1062   ;; Eight bits at a time, least significant bits first
1063   (let ((val 0))
1064     (loop repeat 8
1065           for places fixnum upfrom 0 by 8
1066           for byte fixnum = (prog1 (aref buffer index) (iincf index))
1067           do (setq val (logior val (ash byte places))))
1068     (values val index)))
1069
1070 (defun decode-sfixed32 (buffer index)
1071   "Decodes the next 32-bit signed fixed integer in the buffer at the given index.
1072    Returns both the decoded value and the new index into the buffer.
1073    Watch out, this function turns off all type checking and array bounds checking."
1074   (declare #.$optimize-serialization)
1075   (declare (type (simple-array (unsigned-byte 8)) buffer)
1076            (type fixnum index))
1077   ;; Eight bits at a time, least significant bits first
1078   (let ((val 0))
1079     (declare (type fixnum val))
1080     (loop repeat 4
1081           for places fixnum upfrom 0 by 8
1082           for byte fixnum = (prog1 (aref buffer index) (iincf index))
1083           do (setq val (ilogior val (iash byte places))))
1084     (when (i= (ldb (byte 1 31) val) 1)              ;sign bit set, so negative value
1085       (decf val #.(ash 1 32)))
1086     (values val index)))
1087
1088 (defun decode-sfixed64 (buffer index)
1089   "Decodes the next signed 64-bit fixed integer in the buffer at the given index.
1090    Returns both the decoded value and the new index into the buffer.
1091    Watch out, this function turns off all type checking and array bounds checking."
1092   (declare #.$optimize-serialization)
1093   (declare (type (simple-array (unsigned-byte 8)) buffer)
1094            (type fixnum index))
1095   ;; Eight bits at a time, least significant bits first
1096   (let ((val 0))
1097     (loop repeat 8
1098           for places fixnum upfrom 0 by 8
1099           for byte fixnum = (prog1 (aref buffer index) (iincf index))
1100           do (setq val (logior val (ash byte places))))
1101     (when (i= (ldb (byte 1 63) val) 1)             ;sign bit set, so negative value
1102       (decf val #.(ash 1 64)))
1103     (values val index)))
1104
1105 (defun decode-single (buffer index)
1106   "Decodes the next single float in the buffer at the given index.
1107    Returns both the decoded value and the new index into the buffer.
1108    Watch out, this function turns off all type checking and array bounds checking."
1109   (declare #.$optimize-serialization)
1110   (declare (type (simple-array (unsigned-byte 8)) buffer)
1111            (type fixnum index))
1112   ;; Eight bits at a time, least significant bits first
1113   (let ((bits 0))
1114     (loop repeat 4
1115           for places fixnum upfrom 0 by 8
1116           for byte fixnum = (prog1 (aref buffer index) (iincf index))
1117           do (setq bits (logior bits (ash byte places))))
1118     (when (i= (ldb (byte 1 31) bits) 1)             ;sign bit set, so negative value
1119       (decf bits #.(ash 1 32)))
1120     (values (make-single-float bits) index)))
1121
1122 (defun decode-double (buffer index)
1123   "Decodes the next double float in the buffer at the given index.
1124    Returns both the decoded value and the new index into the buffer.
1125    Watch out, this function turns off all type checking and array bounds checking."
1126   (declare #.$optimize-serialization)
1127   (declare (type (simple-array (unsigned-byte 8)) buffer)
1128            (type fixnum index))
1129   ;; Eight bits at a time, least significant bits first
1130   (let ((low  0)
1131         (high 0))
1132     (loop repeat 4
1133           for places fixnum upfrom 0 by 8
1134           for byte fixnum = (prog1 (aref buffer index) (iincf index))
1135           do (setq low (logior low (ash byte places))))
1136     (loop repeat 4
1137           for places fixnum upfrom 0 by 8
1138           for byte fixnum = (prog1 (aref buffer index) (iincf index))
1139           do (setq high (logior high (ash byte places))))
1140     ;; High bits are signed, but low bits are unsigned
1141     (when (i= (ldb (byte 1 31) high) 1)             ;sign bit set, so negative value
1142       (decf high #.(ash 1 32)))
1143     (values (make-double-float low high) index)))
1144
1145 (defun decode-string (buffer index)
1146   "Decodes the next UTF-8 encoded string in the buffer at the given index.
1147    Returns both the decoded string and the new index into the buffer.
1148    Watch out, this function turns off all type checking and array bounds checking."
1149   (declare #.$optimize-serialization)
1150   (declare (type (simple-array (unsigned-byte 8)) buffer)
1151            (type fixnum index))
1152   (multiple-value-bind (len idx)
1153       (decode-uint32 buffer index)
1154     (declare (type (unsigned-byte 32) len)
1155              (type fixnum idx))
1156     (values (babel:octets-to-string buffer :start idx :end (i+ idx len) :encoding :utf-8) (i+ idx len))))
1157
1158 (defun decode-octets (buffer index)
1159   "Decodes the next octets in the buffer at the given index.
1160    Returns both the decoded value and the new index into the buffer.
1161    Watch out, this function turns off all type checking and array bounds checking."
1162   (declare #.$optimize-serialization)
1163   (declare (type (simple-array (unsigned-byte 8)) buffer)
1164            (type fixnum index))
1165   (multiple-value-bind (len idx)
1166       (decode-uint32 buffer index)
1167     (declare (type (unsigned-byte 32) len)
1168              (type fixnum idx))
1169     (values (subseq buffer idx (i+ idx len)) (i+ idx len))))
1170
1171
1172 ;;; Wire-level lengths
1173 ;;; These are called at the lowest level, so arg types are assumed to be correct
1174
1175 (defun length32 (val)
1176   "Returns the length that 'val' will take when encoded as a 32-bit integer."
1177   (declare #.$optimize-serialization)
1178   (declare (type (unsigned-byte 32) val))
1179   (let ((size 0))
1180     (declare (type fixnum size))
1181     (loop do (progn
1182                (setq val (iash val -7))
1183                (iincf size))
1184           until (i= val 0))
1185     size))
1186
1187 (defun length64 (val)
1188   "Returns the length that 'val' will take when encoded as a 64-bit integer."
1189   (declare #.$optimize-serialization)
1190   (declare (type (unsigned-byte 64) val))
1191   (let ((size 0))
1192     (declare (type fixnum size))
1193     (loop do (progn
1194                (setq val (ash val -7))
1195                (iincf size))
1196           until (zerop val))
1197     size))
1198
1199
1200 ;;; Skipping elements
1201 ;;; This is called at the lowest level, so arg types are assumed to be correct
1202
1203 (defun skip-element (buffer index tag)
1204   "Skip an element in the buffer at the index of the given wire type.
1205    Returns the new index in the buffer.
1206    Watch out, this function turns off all type checking and all array bounds checking."
1207   (declare #.$optimize-serialization)
1208   (declare (type (simple-array (unsigned-byte 8)) buffer)
1209            (type fixnum index)
1210            (type (unsigned-byte 32) tag))
1211   (case (ilogand tag #x7)
1212     ((#.$wire-type-varint)
1213      (loop for byte fixnum = (prog1 (aref buffer index) (iincf index))
1214            until (i< byte 128))
1215      index)
1216     ((#.$wire-type-string)
1217      (multiple-value-bind (len idx)
1218          (decode-uint32 buffer index)
1219        (declare (type (unsigned-byte 32) len)
1220                 (type fixnum idx))
1221        (i+ idx len)))
1222     ((#.$wire-type-32bit)
1223      (i+ index 4))
1224     ((#.$wire-type-64bit)
1225      (i+ index 8))
1226     ((#.$wire-type-start-group)
1227      (loop (multiple-value-bind (new-tag idx)
1228                (decode-uint32 buffer index)
1229              (cond ((not (i= (ilogand new-tag #x7) $wire-type-end-group))
1230                     ;; If it's not the end of a group, skip the next element
1231                     (setq index (skip-element buffer idx new-tag)))
1232                    ;; If it's the end of the expected group, we're done
1233                    ((i= (i- tag $wire-type-start-group) (i- new-tag $wire-type-end-group))
1234                     (return idx))
1235                    (t
1236                     (assert (i= (i- tag $wire-type-start-group) (i- new-tag $wire-type-end-group)) ()
1237                             "Couldn't find a matching end group tag"))))))
1238     (t index)))