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