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