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