wire-format.lisp

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