wire-format.lisp

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