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