serialize.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Free Software published under an MIT-like license. See LICENSE   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012-2013 Google, Inc.  All rights reserved.       ;;;
   6 ;;;                                                                  ;;;
   7 ;;; Original author: Scott McKay                                     ;;;
   8 ;;;                                                                  ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package "PROTO-IMPL")
  12
  13
  14 ;;; Protobuf serialization from Lisp objects
  15
  16 ;;; Size caches
  17
  18 (defgeneric make-size-cache (object type)
  19   (:documentation
  20    "Make an object size cache for 'object'."))
  21
  22 ;; Note that this gets called on the top-level object being serialized
  23 ;; This means that either all the objects in the tree should be subclasses
  24 ;; of 'base-protobuf-message', or none of them should be. If the root is
  25 ;; not a 'base-protobuf-message', then things will work but be slower; if
  26 ;; the root is a 'base-protobuf-message', but some children are not, then
  27 ;; serialization will fail.
  28 (defmethod make-size-cache ((object standard-object) type)
  29   (declare (ignore type))
  30   ;; No '%cached-size' slot in standard objects, create a "visited" table
  31   (make-hash-table))
  32
  33 (defmethod make-size-cache ((object base-protobuf-message) type)
  34   ;; In classes defined by Protobufs, we will use the '%cached-size' slot
  35   ;; This clears the size cache for the tree of objects
  36   (clear-size-cache object type)
  37   nil)
  38
  39
  40 (declaim (inline cached-object-size))
  41 (defun cached-object-size (object visited)
  42   (declare #.$optimize-fast-unsafe)
  43   (if visited
  44     (gethash object visited)
  45     ;; Warning, Will Robinson! Danger!
  46     ;; If there's no 'visited' table, assume there's a cached size slot.
  47     ;; We should use methods speciaized on 'base-protobuf-message',
  48     ;; but we're trying to max out the speed.
  49     (slot-value object '%cached-size)))
  50
  51 (defun (setf cached-object-size) (size object visited)
  52   (declare #.$optimize-fast-unsafe)
  53   (if visited
  54     (setf (gethash object visited) size)
  55     (setf (slot-value object '%cached-size) size)))
  56
  57
  58 (defgeneric clear-size-cache (object type)
  59   (:documentation
  60    "Clear the size cache for a tree of objects."))
  61
  62 (defmethod clear-size-cache ((object standard-object) type)
  63   (declare (ignore type))
  64   nil)
  65
  66 (defmethod clear-size-cache ((object base-protobuf-message) type)
  67   (let ((message (find-message-for-class type)))
  68     (unless message
  69       (serialization-error "There is no Protobuf message having the type ~S" type))
  70     (macrolet ((read-slot (object slot reader)
  71                  `(if ,reader
  72                     (funcall ,reader ,object)
  73                     (slot-value ,object ,slot))))
  74       (labels ((do-field (object trace field)
  75                  (let* ((type   (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
  76                         (slot   (proto-value field))
  77                         (reader (proto-reader field))
  78                         msg)
  79                    (when (or slot reader)
  80                      (cond ((eq (proto-required field) :repeated)
  81                             (cond ((or (and (proto-packed field) (packed-type-p type))
  82                                        (keywordp type)))
  83                                   ((typep (setq msg (and type (find-message trace type))) 'protobuf-message)
  84                                    (setf (slot-value object '%cached-size) nil)
  85                                    (doseq (v (if slot (read-slot object slot reader) (list object)))
  86                                      (dolist (f (proto-fields msg))
  87                                        (do-field v msg f))))))
  88                            (t
  89                             (cond ((keywordp type))
  90                                   ((typep (setq msg (and type (find-message trace type))) 'protobuf-message)
  91                                    (setf (slot-value object '%cached-size) nil)
  92                                    (let ((v (if slot (read-slot object slot reader) object)))
  93                                      (when v
  94                                        (dolist (f (proto-fields msg))
  95                                          (do-field v msg f))))))))))))
  96           (declare (dynamic-extent #'do-field))
  97           (setf (slot-value object '%cached-size) nil)
  98           (dolist (field (proto-fields message))
  99             (do-field object message field))
 100           nil))))
 101
 102
 103 ;;; Serialization
 104
 105 (defun serialize-object-to-file (filename object type &key visited)
 106   "Serializes the object 'object' of type 'type' into the file 'filename'
 107    using the wire format.
 108    'object' and 'type' are the same as for 'serialize-object-to-bytes'."
 109   (with-open-file (stream filename
 110                    :direction :output
 111                    :element-type '(unsigned-byte 8))
 112     (serialize-object-to-stream object type :stream stream :visited visited)))
 113
 114 (defun serialize-object-to-stream (object type &key (stream *standard-output*) visited)
 115   "Serializes the object 'object' of type 'type' onto the stream 'stream'
 116    using the wire format.
 117    'object' and 'type' are the same as for 'serialize-object-to-bytes'."
 118   (let ((buffer (serialize-object-to-bytes object type :visited visited)))
 119     (write-sequence buffer stream)
 120     buffer))
 121
 122 (defun serialize-object-to-bytes (object type &key visited)
 123   "Serializes the object 'object' of type 'type' into a new byte vector
 124    using the wire format.
 125    'type' is the Lisp name of a Protobufs message (usually the name of a
 126    Lisp class) or a 'protobuf-message'.
 127    'visited' is a hash table used to cache object sizes. If it is supplied, it will be
 128    cleared before it is used; otherwise, a fresh table will be created if necessary.
 129    The return value is the buffer containing the serialized object. If the stream is
 130    nil, the buffer is not actually written to anywhere."
 131   (let* ((visited (let ((v (or visited (make-size-cache object type))))
 132                     (when v (clrhash v))
 133                     v))
 134          ;; Use 'object-size' to forcibly recompute all the sizes
 135          (size    (object-size object type visited))
 136          (buffer  (make-byte-vector size)))
 137     (serialize-object object type buffer 0 visited)
 138     buffer))
 139
 140 ;; Serialize the object using the given protobuf type
 141
 142
 143 ;; Allow clients to add their own methods
 144 ;; This is how we address the problem of cycles, e.g. -- if you have an object
 145 ;; that may contain cycles, serialize the cyclic object using a "handle"
 146 (defgeneric serialize-object (object type buffer &optional start visited)
 147   (:documentation
 148    "Serializes the object 'object' of type 'type' into the byte array 'buffer'
 149     using the wire format.
 150     'type' is the Lisp name of a Protobufs message (usually the name of a
 151     Lisp class) or a 'protobuf-message'.
 152     The object is serialized into the byte array given by 'buffer' starting
 153     at the fixnum index 'index' using the wire format.
 154     'visited' is a hash table used to cache object sizes; if this is nil, then
 155     the object caches its size itself in a '%cached-size' slot.
 156     The return value is the buffer containing the serialized object."))
 157
 158 (defmethod serialize-object (object type buffer &optional start visited)
 159   (let ((message (find-message-for-class type)))
 160     (unless message
 161       (serialization-error "There is no Protobuf message having the type ~S" type))
 162     (handler-case
 163        (serialize-object object message buffer start visited)
 164      (error (e)
 165       (serialization-error "Error serializing object ~S: ~A" object (princ-to-string e))))))
 166
 167 ;; 'visited' is used to cache object sizes
 168 ;; If it's non-nil. it must to be a table with the sizes already in it
 169 ;; If it's nil, then the objects must have a '%cached-size' slot
 170 ;; The default method uses metadata from the protobuf "schema" for the message
 171 (defmethod serialize-object (object (message protobuf-message) buffer &optional start visited)
 172   (declare (type (simple-array (unsigned-byte 8)) buffer))
 173   (let ((index (or start 0)))
 174     (declare (type fixnum index))
 175     (macrolet ((read-slot (object slot reader)
 176                  ;; Don't do a boundp check, we assume the object is fully populated
 177                  ;; Unpopulated slots should be "nullable" and will contain nil when empty
 178                  `(if ,reader
 179                     (funcall ,reader ,object)
 180                     (slot-value ,object ,slot))))
 181       (labels ((do-field (object trace field)
 182                  ;; We don't do cycle detection here
 183                  ;; If the client needs it, he can define his own 'serialize-object'
 184                  ;; method to clean things up first
 185                  (let* ((type   (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 186                         (slot   (proto-value field))
 187                         (reader (proto-reader field))
 188                         msg)
 189                    (when (or slot reader)
 190                      (cond ((eq (proto-required field) :repeated)
 191                             (cond ((and (proto-packed field) (packed-type-p type))
 192                                    ;; This is where we handle packed primitive types
 193                                    ;; Packed enums get handled below
 194                                    (let ((tag (make-tag type (proto-index field))))
 195                                      (setq index (serialize-packed (read-slot object slot reader)
 196                                                                    type tag buffer index))))
 197                                   ((keywordp type)
 198                                    (let ((tag (make-tag type (proto-index field))))
 199                                      (doseq (v (read-slot object slot reader))
 200                                        (setq index (serialize-prim v type tag buffer index)))))
 201                                   ((typep (setq msg (and type (or (find-message trace type)
 202                                                                   (find-enum trace type)
 203                                                                   (find-type-alias trace type))))
 204                                           'protobuf-message)
 205                                    (if (eq (proto-message-type msg) :group)
 206                                      (doseq (v (if slot (read-slot object slot reader) (list object)))
 207                                        ;; To serialize a group, we encode a start tag,
 208                                        ;; serialize the fields, then encode an end tag
 209                                        (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
 210                                              (tag2 (make-tag $wire-type-end-group   (proto-index field))))
 211                                          (setq index (encode-uint32 tag1 buffer index))
 212                                          (dolist (f (proto-fields msg))
 213                                            (do-field v msg f))
 214                                          (setq index (encode-uint32 tag2 buffer index))))
 215                                      (doseq (v (if slot (read-slot object slot reader) (list object)))
 216                                        ;; To serialize an embedded message, first say that it's
 217                                        ;; a string, then encode its size, then serialize its fields
 218                                        (let ((tag (make-tag $wire-type-string (proto-index field)))
 219                                              (len (cached-object-size v visited)))
 220                                          (setq index (encode-uint32 tag buffer index))
 221                                          (setq index (encode-uint32 len buffer index)))
 222                                        (dolist (f (proto-fields msg))
 223                                          (do-field v msg f)))))
 224                                   ((typep msg 'protobuf-enum)
 225                                    (let ((tag (make-tag $wire-type-varint (proto-index field))))
 226                                      ;; 'proto-packed-p' of enum types returns nil,
 227                                      ;; so packed enum fields won't be handled above
 228                                      (if (proto-packed field)
 229                                        (setq index (serialize-packed-enum (read-slot object slot reader)
 230                                                                           (proto-values msg) tag buffer index))
 231                                        (doseq (v (read-slot object slot reader))
 232                                          (setq index (serialize-enum v (proto-values msg) tag buffer index))))))
 233                                   ((typep msg 'protobuf-type-alias)
 234                                    (let* ((type (proto-proto-type msg))
 235                                           (tag  (make-tag type (proto-index field))))
 236                                      (doseq (v (read-slot object slot reader))
 237                                        (let ((v (funcall (proto-serializer msg) v)))
 238                                          (setq index (serialize-prim v type tag buffer index))))))
 239                                   (t
 240                                    (undefined-field-type "While serializing ~S,"
 241                                                          object type field))))
 242                            (t
 243                             (cond ((eq type :bool)
 244                                    ;; We have to handle optional boolean fields specially
 245                                    ;; because "false" and nil are the same value in Lisp
 246                                    (let ((v (cond ((or (eq (proto-required field) :required)
 247                                                        (null slot))
 248                                                    (read-slot object slot reader))
 249                                                   ((slot-boundp object slot)
 250                                                    (read-slot object slot reader))
 251                                                   (t :unbound))))
 252                                      (unless (eq v :unbound)
 253                                        (let ((tag (make-tag :bool (proto-index field))))
 254                                          (setq index (serialize-prim v type tag buffer index))))))
 255                                   ((keywordp type)
 256                                    (let ((v (read-slot object slot reader)))
 257                                      (when (and v (not (equal v (proto-default field))))
 258                                        (let ((tag (make-tag type (proto-index field))))
 259                                          (setq index (serialize-prim v type tag buffer index))))))
 260                                   ((typep (setq msg (and type (or (find-message trace type)
 261                                                                   (find-enum trace type)
 262                                                                   (find-type-alias trace type))))
 263                                           'protobuf-message)
 264                                    (let ((v (if slot (read-slot object slot reader) object)))
 265                                      (when v
 266                                        (if (eq (proto-message-type msg) :group)
 267                                          (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
 268                                                (tag2 (make-tag $wire-type-end-group   (proto-index field))))
 269                                            (setq index (encode-uint32 tag1 buffer index))
 270                                            (dolist (f (proto-fields msg))
 271                                              (do-field v msg f))
 272                                            (setq index (encode-uint32 tag2 buffer index)))
 273                                          (let ((tag (make-tag $wire-type-string (proto-index field)))
 274                                                (len (cached-object-size v visited)))
 275                                            (setq index (encode-uint32 tag buffer index))
 276                                            (setq index (encode-uint32 len buffer index))
 277                                            (dolist (f (proto-fields msg))
 278                                              (do-field v msg f)))))))
 279                                   ((typep msg 'protobuf-enum)
 280                                    (let ((v (read-slot object slot reader)))
 281                                      (when (and v (not (eql v (proto-default field))))
 282                                        (let ((tag (make-tag $wire-type-varint (proto-index field))))
 283                                          (setq index (serialize-enum v (proto-values msg) tag buffer index))))))
 284                                   ((typep msg 'protobuf-type-alias)
 285                                    (let ((v (read-slot object slot reader)))
 286                                      (when v
 287                                        (let* ((v    (funcall (proto-serializer msg) v))
 288                                               (type (proto-proto-type msg))
 289                                               (tag  (make-tag type (proto-index field))))
 290                                          (setq index (serialize-prim v type tag buffer index))))))
 291                                   (t
 292                                    (undefined-field-type "While serializing ~S,"
 293                                                          object type field)))))))))
 294         (declare (dynamic-extent #'do-field))
 295         (dolist (field (proto-fields message))
 296           (do-field object message field))))
 297     (values buffer index)))
 298
 299
 300 ;;; Deserialization
 301
 302 (defun deserialize-object-from-file (type filename)
 303   "Deserializes an object of the given type 'type' from the given file
 304    as a Protobuf object."
 305   (with-open-file (stream filename
 306                    :direction :input
 307                    :element-type '(unsigned-byte 8))
 308     (deserialize-object-from-stream type :stream stream)))
 309
 310 (defun deserialize-object-from-stream (type &key (stream *standard-input*))
 311   "Deserializes an object of the given type 'type' from the given stream
 312    as a Protobuf object."
 313   (let* ((size    (file-length stream))
 314          (buffer  (make-byte-vector size)))
 315     (read-sequence buffer stream)
 316     (deserialize-object type buffer 0 size)))
 317
 318 (defun deserialize-object-from-bytes (type buffer)
 319   "Deserializes an object of the given type 'type' from the given stream
 320    as a Protobuf object.
 321    'type' is the Lisp name of a Protobufs message (usually the name of a
 322    Lisp class) or a 'protobuf-message'.
 323    The return value is the object."
 324   (deserialize-object type buffer))
 325
 326 ;; Allow clients to add their own methods
 327 ;; This is you might preserve object identity, e.g.
 328 (defgeneric deserialize-object (type buffer &optional start end end-tag)
 329   (:documentation
 330    "Deserializes an object of the given type 'type' as a Protobufs object.
 331     'type' is the Lisp name of a Protobufs message (usually the name of a
 332     Lisp class) or a 'protobuf-message'.
 333     The encoded bytes are in the byte array given by 'buffer' starting at
 334     the fixnum index 'start' up to the end of the buffer, given by 'end'.
 335     'start' defaults to 0, 'end' defaults to the length of the buffer.
 336     'end-tag' is used internally to handle the (deprecated) \"group\" feature.
 337     The return values are the object and the index at which deserialization stopped.."))
 338
 339 (defmethod deserialize-object (type buffer &optional start end (end-tag 0))
 340   (let ((message (find-message-for-class type)))
 341     (unless message
 342       (serialization-error "There is no Protobuf message having the type ~S" type))
 343     (handler-case
 344        (deserialize-object message buffer start end end-tag)
 345      (error (e)
 346       (serialization-error "Error deserializing buffer ~S: ~A" buffer (princ-to-string e))))))
 347
 348 ;; The default method uses metadata from the protobuf "schema" for the message
 349 (defmethod deserialize-object ((message protobuf-message) buffer &optional start end (end-tag 0))
 350   (declare (type (simple-array (unsigned-byte 8)) buffer))
 351   (let ((index   (or start 0))
 352         (length  (or end (length buffer))))
 353     (declare (type fixnum index length))
 354     (macrolet ((read-slot (object slot reader)
 355                  `(if ,reader
 356                     (funcall ,reader ,object)
 357                     (slot-value ,object ,slot)))
 358                (write-slot (object slot writer value)
 359                  (with-gensyms (vval)
 360                    `(let ((,vval ,value))
 361                       (if ,writer
 362                         (funcall ,writer ,object ,vval)
 363                         (setf (slot-value ,object ,slot) ,vval)))))
 364                (push-slot (object slot reader writer value)
 365                  (with-gensyms (vvals)
 366                    `(let ((,vvals (read-slot ,object ,slot ,reader)))
 367                       (if (i= (length ,vvals) 0)
 368                         ;; We need the initial value to be a stretchy vector,
 369                         ;; so scribble over it just to make sure
 370                         (let ((,vvals (make-array 1
 371                                         :fill-pointer t :adjustable t
 372                                         :initial-contents (list ,value))))
 373                           (write-slot ,object ,slot ,writer ,vvals))
 374                         (vector-push-extend ,value ,vvals))))))
 375       (labels ((deserialize (type trace end end-tag)
 376                  (declare (type fixnum end end-tag))
 377                  (let* ((message (find-message trace type))
 378                         (object  (and message
 379                                       (make-instance (or (proto-alias-for message) (proto-class message)))))
 380                         ;; All the slots into which we store a repeated element
 381                         ;; These will be reversed at the end of deserialization
 382                         (rslots ()))
 383                    (loop
 384                      (multiple-value-bind (tag idx)
 385                          (if (i< index end) (decode-uint32 buffer index) (values 0 index))
 386                        ;; We're done if we've gotten to the end index or
 387                        ;; we see an end tag that matches a previous group's start tag
 388                        ;; Note that the default end tag is 0, which is also an end of
 389                        ;; message marker (there can never be "real" zero tags because
 390                        ;; field indices start at 1)
 391                        (setq index idx)
 392                        (when (i= tag end-tag)
 393                          ;; Reverse the repeated slots
 394                          (dolist (field rslots)
 395                            (let ((slot   (proto-value field))
 396                                  (reader (proto-reader field))
 397                                  (writer (proto-writer field)))
 398                              (write-slot object slot writer
 399                                          (nreverse (read-slot object slot reader)))))
 400                          (return-from deserialize
 401                            (values object index)))
 402                        (let* ((fidx  (ilogand (iash tag -3) #x1FFFFFFF))
 403                               (field (find fidx (proto-fields message) :key #'proto-index))
 404                               (type  (and field (if (eq (proto-class field) 'boolean) :bool (proto-class field))))
 405                               ;; It's OK for this to be null
 406                               ;; That means we're parsing some version of a message
 407                               ;; that has the field, but our current message does not
 408                               ;; We still have to deserialize everything, though
 409                               (slot   (and field (proto-value field)))
 410                               (reader (and field (proto-reader field)))
 411                               (writer (and field (proto-writer field)))
 412                               msg)
 413                          (if (null field)
 414                            ;; If there's no field descriptor for this index, just skip
 415                            ;; the next element in the buffer having the given wire type
 416                            (setq index (skip-element buffer index tag))
 417                            ;; We don't explicitly check for mismatched wire type, running past the
 418                            ;; end of the buffer, etc; instead, we'll count on the high likelihood
 419                            ;; of some kind of an error getting signalled (e.g., array out of bounds)
 420                            ;; and catch it at a higher level. Yay, Lisp!
 421                            (cond ((and field (eq (proto-required field) :repeated))
 422                                   (let ((vectorp (vector-field-p field)))
 423                                     (cond ((and (proto-packed field) (packed-type-p type))
 424                                            (multiple-value-bind (values idx)
 425                                                (deserialize-packed type buffer index)
 426                                              (setq index idx)
 427                                              (if vectorp
 428                                                (let ((values (make-array (length values)
 429                                                                :fill-pointer t :adjustable t
 430                                                                :initial-contents values)))
 431                                                  (write-slot object slot writer values))
 432                                                (write-slot object slot writer values))))
 433                                           ((keywordp type)
 434                                            (multiple-value-bind (val idx)
 435                                                (deserialize-prim type buffer index)
 436                                              (setq index idx)
 437                                              (cond (vectorp
 438                                                     (push-slot object slot reader writer val))
 439                                                    (t
 440                                                     (pushnew field rslots)
 441                                                     ;; This "push" could type-check the entire list if
 442                                                     ;; there's a parameterized list type in effect,
 443                                                     ;; so you'll want to avoid using such types
 444                                                     ;; We'll reverse the slots at the last minute
 445                                                     (write-slot object slot writer
 446                                                                 (cons val (read-slot object slot reader)))))))
 447                                           ((typep (setq msg (and type (or (find-message trace type)
 448                                                                           (find-enum trace type)
 449                                                                           (find-type-alias trace type))))
 450                                                   'protobuf-message)
 451                                            (if (eq (proto-message-type msg) :group)
 452                                              (let* ((etag (make-tag $wire-type-end-group fidx))
 453                                                     (obj  (deserialize type msg length etag)))
 454                                                (cond (vectorp
 455                                                       (push-slot object slot reader writer obj))
 456                                                      (t
 457                                                       (pushnew field rslots)
 458                                                       (write-slot object slot writer
 459                                                                   (cons obj (read-slot object slot reader))))))
 460                                              (multiple-value-bind (len idx)
 461                                                  (decode-uint32 buffer index)
 462                                                (setq index idx)
 463                                                (let ((obj (deserialize type msg (+ index len) 0)))
 464                                                  (cond (vectorp
 465                                                         (push-slot object slot reader writer obj))
 466                                                        (t
 467                                                         (pushnew field rslots)
 468                                                         (write-slot object slot writer
 469                                                                     (cons obj (read-slot object slot reader)))))))))
 470                                           ((typep msg 'protobuf-enum)
 471                                            (if (proto-packed field)
 472                                              (multiple-value-bind (values idx)
 473                                                  (deserialize-packed-enum (proto-values msg) buffer index)
 474                                                (setq index idx)
 475                                                (if vectorp
 476                                                  (let ((values (make-array (length values)
 477                                                                  :fill-pointer t :adjustable t
 478                                                                  :initial-contents values)))
 479                                                    (write-slot object slot writer values))
 480                                                  (write-slot object slot writer values)))
 481                                              (multiple-value-bind (val idx)
 482                                                  (deserialize-enum (proto-values msg) buffer index)
 483                                                (setq index idx)
 484                                                (cond (vectorp
 485                                                       (push-slot object slot reader writer val))
 486                                                      (t
 487                                                       (pushnew field rslots)
 488                                                       (write-slot object slot writer
 489                                                                   (cons val (read-slot object slot reader))))))))
 490                                           ((typep msg 'protobuf-type-alias)
 491                                            (let ((type (proto-proto-type msg)))
 492                                              (multiple-value-bind (val idx)
 493                                                  (deserialize-prim type buffer index)
 494                                                (setq index idx)
 495                                                (cond (vectorp
 496                                                       (push-slot object slot reader writer
 497                                                                  (funcall (proto-deserializer msg) val)))
 498                                                      (t
 499                                                       (pushnew field rslots)
 500                                                       (write-slot object slot writer
 501                                                                   (cons (funcall (proto-deserializer msg) val)
 502                                                                         (read-slot object slot reader)))))))))))
 503                                  (t
 504                                   (cond ((keywordp type)
 505                                          (multiple-value-bind (val idx)
 506                                              (deserialize-prim type buffer index)
 507                                            (setq index idx)
 508                                            (write-slot object slot writer val)))
 509                                         ((typep (setq msg (and type (or (find-message trace type)
 510                                                                         (find-enum trace type)
 511                                                                         (find-type-alias trace type))))
 512                                                 'protobuf-message)
 513                                          ;;--- If there's already a value in the slot, merge messages
 514                                          (if (eq (proto-message-type msg) :group)
 515                                            (let* ((etag (make-tag $wire-type-end-group fidx))
 516                                                   (obj  (deserialize type msg length etag)))
 517                                              (write-slot object slot writer obj))
 518                                            (multiple-value-bind (len idx)
 519                                                (decode-uint32 buffer index)
 520                                              (setq index idx)
 521                                              (let ((obj (deserialize type msg (+ index len) 0)))
 522                                                (write-slot object slot writer obj)))))
 523                                         ((typep msg 'protobuf-enum)
 524                                          (multiple-value-bind (val idx)
 525                                              (deserialize-enum (proto-values msg) buffer index)
 526                                            (setq index idx)
 527                                            (write-slot object slot writer val)))
 528                                         ((typep msg 'protobuf-type-alias)
 529                                          (let ((type (proto-proto-type msg)))
 530                                            (multiple-value-bind (val idx)
 531                                                (deserialize-prim type buffer index)
 532                                              (setq index idx)
 533                                              (write-slot object slot writer
 534                                                          (funcall (proto-deserializer msg) val)))))))))))))))
 535         (declare (dynamic-extent #'deserialize))
 536         (deserialize (proto-class message) message length end-tag)))))
 537
 538
 539 ;;; Object sizes
 540
 541 ;; Allow clients to add their own methods
 542 ;; This is how we address the problem of cycles, e.g. -- if you have an object
 543 ;; that may contain cycles, return the size of the "handle" to the object
 544 (defgeneric object-size (object type &optional visited)
 545   (:documentation
 546    "Computes the size in bytes of the object 'object' of type 'type'.
 547     'type' is the Lisp name of a Protobufs message (usually the name of a
 548     Lisp class) or a 'protobuf-message'.
 549     'visited' is either a hash table used to cache object sizes,
 550     or is nil, in which case the objects must have a '%cached-size' slot in them.
 551     The return value is the size of the object in bytes."))
 552
 553 (defmethod object-size (object type &optional visited)
 554   (let ((message (find-message-for-class type)))
 555     (unless message
 556       (serialization-error "There is no Protobuf message having the type ~S" type))
 557     (object-size object message visited)))
 558
 559 ;; 'visited' is used to cache object sizes
 560 ;; The default method uses metadata from the protobuf "schema" for the message
 561 (defmethod object-size (object (message protobuf-message) &optional visited)
 562   (let ((size 0))
 563     (declare (type fixnum size))
 564     (macrolet ((read-slot (object slot reader)
 565                  ;; Don't do a boundp check, we assume the object is fully populated
 566                  ;; Unpopulated slots should be "nullable" and will contain nil when empty
 567                  `(if ,reader
 568                     (funcall ,reader ,object)
 569                     (slot-value ,object ,slot))))
 570       (labels ((do-field (object trace field)
 571                  ;; We don't do cycle detection here
 572                  ;; If the client needs it, he can define his own 'object-size'
 573                  ;; method to clean things up first
 574                  (let* ((type   (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 575                         (slot   (proto-value field))
 576                         (reader (proto-reader field))
 577                         msg)
 578                    (when (or slot reader)
 579                      (cond ((eq (proto-required field) :repeated)
 580                             (cond ((and (proto-packed field) (packed-type-p type))
 581                                    (let ((tag (make-tag type (proto-index field))))
 582                                      (iincf size (packed-size (read-slot object slot reader) type tag))))
 583                                   ((keywordp type)
 584                                    (let ((tag (make-tag type (proto-index field))))
 585                                      (doseq (v (read-slot object slot reader))
 586                                        (iincf size (prim-size v type tag)))))
 587                                   ((typep (setq msg (and type (or (find-message trace type)
 588                                                                   (find-enum trace type)
 589                                                                   (find-type-alias trace type))))
 590                                           'protobuf-message)
 591                                    (if (eq (proto-message-type msg) :group)
 592                                      (doseq (v (if slot (read-slot object slot reader) (list object)))
 593                                        (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
 594                                              (tag2 (make-tag $wire-type-end-group   (proto-index field))))
 595                                          (iincf size (varint-length tag1))
 596                                          (dolist (f (proto-fields msg))
 597                                            (do-field v msg f))
 598                                          (iincf size (varint-length tag2))))
 599                                      (doseq (v (if slot (read-slot object slot reader) (list object)))
 600                                        (let ((tag (make-tag $wire-type-string (proto-index field)))
 601                                              (len (or (cached-object-size v visited)
 602                                                       (object-size v msg visited))))
 603                                          (iincf size (varint-length tag))
 604                                          (iincf size (varint-length len))
 605                                          (dolist (f (proto-fields msg))
 606                                            (do-field v msg f))))))
 607                                   ((typep msg 'protobuf-enum)
 608                                    (let ((tag (make-tag $wire-type-varint (proto-index field))))
 609                                      (if (proto-packed field)
 610                                        (iincf size (packed-enum-size (read-slot object slot reader) type tag))
 611                                        (doseq (v (read-slot object slot reader))
 612                                          (iincf size (enum-size v (proto-values msg) tag))))))
 613                                   ((typep msg 'protobuf-type-alias)
 614                                    (let* ((type (proto-proto-type msg))
 615                                           (tag  (make-tag type (proto-index field))))
 616                                      (doseq (v (read-slot object slot reader))
 617                                        (let ((v (funcall (proto-serializer msg) v)))
 618                                          (iincf size (prim-size v type tag))))))
 619                                   (t
 620                                    (undefined-field-type "While computing the size of ~S,"
 621                                                          object type field))))
 622                            (t
 623                             (cond ((eq type :bool)
 624                                    (let ((v (cond ((or (eq (proto-required field) :required)
 625                                                        (null slot))
 626                                                    (read-slot object slot reader))
 627                                                   ((slot-boundp object slot)
 628                                                    (read-slot object slot reader))
 629                                                   (t :unbound))))
 630                                      (unless (eq v :unbound)
 631                                        (let ((tag (make-tag :bool (proto-index field))))
 632                                          (iincf size (prim-size v type tag))))))
 633                                   ((keywordp type)
 634                                    (let ((v (read-slot object slot reader)))
 635                                      (when (and v (not (equal v (proto-default field))))
 636                                        (let ((tag (make-tag type (proto-index field))))
 637                                          (iincf size (prim-size v type tag))))))
 638                                   ((typep (setq msg (and type (or (find-message trace type)
 639                                                                   (find-enum trace type)
 640                                                                   (find-type-alias trace type))))
 641                                           'protobuf-message)
 642                                    (let ((v (if slot (read-slot object slot reader) object)))
 643                                      (when v
 644                                        (if (eq (proto-message-type msg) :group)
 645                                          (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
 646                                                (tag2 (make-tag $wire-type-end-group   (proto-index field))))
 647                                            (iincf size (varint-length tag1))
 648                                            (dolist (f (proto-fields msg))
 649                                              (do-field v msg f))
 650                                            (iincf size (varint-length tag2)))
 651                                          (let ((tag (make-tag $wire-type-string (proto-index field)))
 652                                                (len (or (cached-object-size v visited)
 653                                                         (object-size v msg visited))))
 654                                            (iincf size (varint-length tag))
 655                                            (iincf size (varint-length len))
 656                                            (dolist (f (proto-fields msg))
 657                                              (do-field v msg f)))))))
 658                                   ((typep msg 'protobuf-enum)
 659                                    (let ((v (read-slot object slot reader)))
 660                                      (when (and v (not (eql v (proto-default field))))
 661                                        (let ((tag (make-tag $wire-type-varint (proto-index field))))
 662                                          (iincf size (enum-size (read-slot object slot reader) (proto-values msg) tag))))))
 663                                   ((typep msg 'protobuf-type-alias)
 664                                    (let ((v (read-slot object slot reader)))
 665                                      (when v
 666                                        (let* ((v    (funcall (proto-serializer msg) v))
 667                                               (type (proto-proto-type msg))
 668                                               (tag  (make-tag type (proto-index field))))
 669                                          (iincf size (prim-size v type tag))))))
 670                                   (t
 671                                    (undefined-field-type "While computing the size of ~S,"
 672                                                          object type field)))))))))
 673         (declare (dynamic-extent #'do-field))
 674         (dolist (field (proto-fields message))
 675           (do-field object message field))
 676         (setf (cached-object-size object visited) size)          ;cache the size
 677         size))))
 678
 679 \f
 680 ;;; Compile-time generation of serializers
 681 ;;; Type-checking is done at the top-level methods specialized on 'symbol',
 682 ;;; so we turn off all type checking at the level of these functions
 683
 684 ;; Note well: keep this in sync with the main 'serialize-object' method above
 685 (defun generate-serializer (message)
 686   "Generate a 'serialize-object' method for the given message."
 687   (with-gensyms (vobj vbuf vidx vval vclass)
 688     (when (null (proto-fields message))
 689       (return-from generate-serializer
 690         `(defmethod serialize-object
 691            (,vobj (,vclass (eql ,message)) ,vbuf &optional (,vidx 0) visited)
 692          (declare #.$optimize-serialization)
 693          (declare (ignorable ,vobj ,vclass visited)
 694                   (type (simple-array (unsigned-byte 8)) ,vbuf)
 695                   (type fixnum ,vidx))
 696          (values ,vbuf ,vidx))))
 697     (with-collectors ((serializers collect-serializer))
 698       (dolist (field (proto-fields message))
 699         (let* ((class  (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 700                (msg    (and class (not (keywordp class))
 701                             (or (find-message message class)
 702                                 (find-enum message class)
 703                                 (find-type-alias message class))))
 704                (reader (cond ((proto-reader field)
 705                               `(,(proto-reader field) ,vobj))
 706                              ((proto-value field)
 707                               `(slot-value ,vobj ',(proto-value field)))))
 708                (index  (proto-index field)))
 709           (when reader
 710             (cond ((eq (proto-required field) :repeated)
 711                    (let* ((vectorp  (vector-field-p field))
 712                           (iterator (if vectorp 'dovector 'dolist)))
 713                      (cond ((and (proto-packed field) (packed-type-p class))
 714                             (collect-serializer
 715                              (let ((tag (make-tag class index)))
 716                                `(setq ,vidx (serialize-packed ,reader ,class ,tag ,vbuf ,vidx
 717                                                               ,vectorp)))))
 718                            ((keywordp class)
 719                             (collect-serializer
 720                              (let ((tag (make-tag class index)))
 721                                `(,iterator (,vval ,reader)
 722                                   (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))))
 723                            ((typep msg 'protobuf-message)
 724                             (collect-serializer
 725                              (if (eq (proto-message-type msg) :group)
 726                                (let ((tag1 (make-tag $wire-type-start-group index))
 727                                      (tag2 (make-tag $wire-type-end-group   index)))
 728                                  `(,iterator (,vval ,reader)
 729                                     (let ((len (cached-object-size ,vval visited)))
 730                                       (setq ,vidx (encode-uint32 ,tag1 ,vbuf ,vidx))
 731                                       (serialize-object ,vval ,msg ,vbuf ,vidx visited)
 732                                       (iincf ,vidx len)
 733                                       (setq ,vidx (encode-uint32 ,tag2 ,vbuf ,vidx)))))
 734                                (let ((tag (make-tag $wire-type-string index)))
 735                                  `(,iterator (,vval ,reader)
 736                                     (let ((len (cached-object-size ,vval visited)))
 737                                       (setq ,vidx (encode-uint32 ,tag ,vbuf ,vidx))
 738                                       (setq ,vidx (encode-uint32 len ,vbuf ,vidx))
 739                                       (serialize-object ,vval ,msg ,vbuf ,vidx visited)
 740                                       (iincf ,vidx len)))))))
 741                            ((typep msg 'protobuf-enum)
 742                             (collect-serializer
 743                              (let ((tag (make-tag $wire-type-varint index)))
 744                                (if (proto-packed field)
 745                                  `(setq ,vidx (serialize-packed-enum ,reader '(,@(proto-values msg)) ,tag ,vbuf ,vidx
 746                                                                      ,vectorp))
 747
 748                                  `(,iterator (,vval ,reader)
 749                                     (setq ,vidx (serialize-enum ,vval '(,@(proto-values msg)) ,tag ,vbuf ,vidx)))))))
 750                            ((typep msg 'protobuf-type-alias)
 751                             (collect-serializer
 752                              (let* ((class (proto-proto-type msg))
 753                                     (tag   (make-tag class (proto-index field))))
 754                                `(,iterator (,vval ,reader)
 755                                   (let ((,vval (funcall #',(proto-serializer msg) ,vval)))
 756                                     (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx)))))))
 757                            (t
 758                             (undefined-field-type "While generating 'serialize-object' for ~S,"
 759                                                   message class field)))))
 760                   (t
 761                    (cond ((keywordp class)
 762                           (collect-serializer
 763                            (let ((tag (make-tag class index)))
 764                              (if (eq class :bool)
 765                                (if (or (eq (proto-required field) :required)
 766                                        (null (proto-value field)))
 767                                  `(let ((,vval ,reader))
 768                                     (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx)))
 769                                  `(let ((,vval (cond ((slot-boundp ,vobj ',(proto-value field))
 770                                                       ,reader)
 771                                                      (t :unbound))))
 772                                     (unless (eq ,vval :unbound)
 773                                       (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx)))))
 774                                (if (empty-default-p field)
 775                                  `(let ((,vval ,reader))
 776                                     (when ,vval
 777                                       (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))
 778                                  `(let ((,vval ,reader))
 779                                     (when (and ,vval (not (equal ,vval ',(proto-default field))))
 780                                       (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx)))))))))
 781                          ((typep msg 'protobuf-message)
 782                           (collect-serializer
 783                            (if (eq (proto-message-type msg) :group)
 784                              (let ((tag1 (make-tag $wire-type-start-group index))
 785                                    (tag2 (make-tag $wire-type-end-group   index)))
 786                                `(let ((,vval ,reader))
 787                                   (when ,vval
 788                                     (let ((len (cached-object-size ,vval visited)))
 789                                       (setq ,vidx (encode-uint32 ,tag1 ,vbuf ,vidx))
 790                                       (serialize-object ,vval ,msg ,vbuf ,vidx visited)
 791                                       (iincf ,vidx len)
 792                                       (setq ,vidx (encode-uint32 ,tag2 ,vbuf ,vidx))))))
 793                              (let ((tag (make-tag $wire-type-string index)))
 794                                `(let ((,vval ,reader))
 795                                   (when ,vval
 796                                     (let ((len (cached-object-size ,vval visited)))
 797                                       (setq ,vidx (encode-uint32 ,tag ,vbuf ,vidx))
 798                                       (setq ,vidx (encode-uint32 len ,vbuf ,vidx))
 799                                       (serialize-object ,vval ,msg ,vbuf ,vidx visited)
 800                                       (iincf ,vidx len))))))))
 801                          ((typep msg 'protobuf-enum)
 802                           (collect-serializer
 803                            (let ((tag (make-tag $wire-type-varint index)))
 804                              (if (empty-default-p field)
 805                                `(let ((,vval ,reader))
 806                                   (when ,vval
 807                                     (setq ,vidx (serialize-enum ,vval '(,@(proto-values msg)) ,tag ,vbuf ,vidx))))
 808                                `(let ((,vval ,reader))
 809                                   (when (and ,vval (not (eql ,vval ',(proto-default field))))
 810                                     (setq ,vidx (serialize-enum ,vval '(,@(proto-values msg)) ,tag ,vbuf ,vidx))))))))
 811                          ((typep msg 'protobuf-type-alias)
 812                           (collect-serializer
 813                            (let* ((class (proto-proto-type msg))
 814                                   (tag   (make-tag class (proto-index field))))
 815                              `(let ((,vval ,reader))
 816                                 (when ,vval
 817                                   (let ((,vval (funcall #',(proto-serializer msg) ,vval)))
 818                                     (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))))))
 819                          (t
 820                           (undefined-field-type "While generating 'serialize-object' for ~S,"
 821                                                 message class field))))))))
 822       `(defmethod serialize-object
 823            (,vobj (,vclass (eql ,message)) ,vbuf &optional (,vidx 0) visited)
 824          (declare #.$optimize-serialization)
 825          (declare (ignorable visited)
 826                   (type (simple-array (unsigned-byte 8)) ,vbuf)
 827                   (type fixnum ,vidx))
 828          ,@serializers
 829          (values ,vbuf ,vidx)))))
 830
 831 ;; Note well: keep this in sync with the main 'deserialize-object' method above
 832 (defun generate-deserializer (message)
 833   "Generate a 'deserialize-object' method for the given message."
 834   (with-gensyms (vclass vbuf vidx vlen vendtag vobj vval)
 835     (when (null (proto-fields message))
 836       (return-from generate-deserializer
 837         `(defmethod deserialize-object
 838              ((,vclass (eql ,message)) ,vbuf &optional ,vidx ,vlen (,vendtag 0))
 839            (declare #.$optimize-serialization)
 840            (declare (ignorable ,vclass ,vbuf ,vlen ,vendtag)
 841                     (type (simple-array (unsigned-byte 8)) ,vbuf))
 842            (let ((,vidx (or ,vidx 0)))
 843              (declare (type fixnum ,vidx))
 844              (let ((,vobj (make-instance ',(or (proto-alias-for message) (proto-class message)))))
 845                (values ,vobj ,vidx))))))
 846     (with-collectors ((deserializers collect-deserializer)
 847                       ;; For tracking repeated slots that will need to be reversed
 848                       (rslots collect-rslot))
 849       (flet ((read-slot (object field)
 850                (cond ((proto-reader field)
 851                       `(,(proto-reader field) ,object))
 852                      ((proto-value field)
 853                       `(slot-value ,object ',(proto-value field)))))
 854              (write-slot (object field value)
 855                (cond ((proto-writer field)
 856                       `(,(proto-writer field) ,object ,value))
 857                      ((proto-value field)
 858                       `(setf (slot-value ,object ',(proto-value field)) ,value)))))
 859         (dolist (field (proto-fields message))
 860           (let* ((class  (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 861                  (msg    (and class (not (keywordp class))
 862                               (or (find-message message class)
 863                                   (find-enum message class)
 864                                   (find-type-alias message class))))
 865                  (index  (proto-index field)))
 866             (cond ((eq (proto-required field) :repeated)
 867                    (cond ((and (proto-packed field) (packed-type-p class))
 868                           (collect-deserializer
 869                            `((,(make-tag class index))
 870                              (multiple-value-bind (,vval idx)
 871                                  (deserialize-packed ,class ,vbuf ,vidx)
 872                                (setq ,vidx idx)
 873                                ,@(when (vector-field-p field)
 874                                    `((setq ,vval (make-array (length ,vval)
 875                                                    :fill-pointer t :adjustable t
 876                                                    :initial-contents ,vval))))
 877                                ,(write-slot vobj field vval)))))
 878                          ((keywordp class)
 879                           (let ((temp (gensym (string (proto-value field)))))
 880                             (collect-rslot (list field temp))
 881                             (collect-deserializer
 882                              `((,(make-tag class index))
 883                                (multiple-value-bind (,vval idx)
 884                                    (deserialize-prim ,class ,vbuf ,vidx)
 885                                  (setq ,vidx idx)
 886                                  (push ,vval ,temp))))))
 887                          ((typep msg 'protobuf-message)
 888                           (let ((temp (gensym (string (proto-value field)))))
 889                             (collect-rslot (list field temp))
 890                             (collect-deserializer
 891                              (if (eq (proto-message-type msg) :group)
 892                                `((,(make-tag $wire-type-start-group index))
 893                                  (multiple-value-bind (,vval idx)
 894                                      (deserialize-object ,msg ,vbuf ,vidx ,vlen
 895                                                          ,(make-tag $wire-type-end-group index))
 896                                    (setq ,vidx idx)
 897                                    (push ,vval ,temp)))
 898                                `((,(make-tag $wire-type-string index))
 899                                  (multiple-value-bind (len idx)
 900                                      (decode-uint32 ,vbuf ,vidx)
 901                                    (setq ,vidx idx)
 902                                    (multiple-value-bind (,vval idx)
 903                                        (deserialize-object ,msg ,vbuf ,vidx (i+ ,vidx len) 0)
 904                                      (setq ,vidx idx)
 905                                      (push ,vval ,temp))))))))
 906                          ((typep msg 'protobuf-enum)
 907                           (if (proto-packed field)
 908                             (collect-deserializer
 909                              `((,(make-tag $wire-type-varint index))
 910                                (multiple-value-bind (,vval idx)
 911                                    (deserialize-packed-enum '(,@(proto-values msg)) ,vbuf ,vidx)
 912                                  (setq ,vidx idx)
 913                                  ,(write-slot vobj field vval))))
 914                             (let ((temp (gensym (string (proto-value field)))))
 915                               (collect-rslot (list field temp))
 916                               (collect-deserializer
 917                                `((,(make-tag $wire-type-varint index))
 918                                  (multiple-value-bind (,vval idx)
 919                                      (deserialize-enum '(,@(proto-values msg)) ,vbuf ,vidx)
 920                                    (setq ,vidx idx)
 921                                    (push ,vval ,temp)))))))
 922                          ((typep msg 'protobuf-type-alias)
 923                           (let ((class (proto-proto-type msg))
 924                                 (temp  (gensym (string (proto-value field)))))
 925                             (collect-rslot (list field temp))
 926                             (collect-deserializer
 927                              `((,(make-tag class index))
 928                                (multiple-value-bind (,vval idx)
 929                                    (deserialize-prim ,class ,vbuf ,vidx)
 930                                  (setq ,vidx idx)
 931                                  (push (funcall #',(proto-deserializer msg) ,vval) ,temp))))))
 932                          (t
 933                           (undefined-field-type "While generating 'deserialize-object' for ~S,"
 934                                                 message class field))))
 935                   (t
 936                    (cond ((keywordp class)
 937                           (collect-deserializer
 938                            `((,(make-tag class index))
 939                              (multiple-value-bind (,vval idx)
 940                                  (deserialize-prim ,class ,vbuf ,vidx)
 941                                (setq ,vidx idx)
 942                                ,(write-slot vobj field vval)))))
 943                          ((typep msg 'protobuf-message)
 944                           (collect-deserializer
 945                            (if (eq (proto-message-type msg) :group)
 946                              `((,(make-tag $wire-type-start-group index))
 947                                (multiple-value-bind (,vval idx)
 948                                    (deserialize-object ,msg ,vbuf ,vidx  ,vlen
 949                                                        ,(make-tag $wire-type-end-group index))
 950                                  (setq ,vidx idx)
 951                                  ,(write-slot vobj field vval)))
 952                              `((,(make-tag $wire-type-string index))
 953                                (multiple-value-bind (len idx)
 954                                    (decode-uint32 ,vbuf ,vidx)
 955                                  (setq ,vidx idx)
 956                                  (multiple-value-bind (,vval idx)
 957                                      (deserialize-object ,msg ,vbuf ,vidx (i+ ,vidx len) 0)
 958                                    (setq ,vidx idx)
 959                                    ,(write-slot vobj field vval)))))))
 960                          ((typep msg 'protobuf-enum)
 961                           (collect-deserializer
 962                            `((,(make-tag $wire-type-varint index))
 963                              (multiple-value-bind (,vval idx)
 964                                  (deserialize-enum '(,@(proto-values msg)) ,vbuf ,vidx)
 965                                (setq ,vidx idx)
 966                                ,(write-slot vobj field vval)))))
 967                          ((typep msg 'protobuf-type-alias)
 968                           (let ((class (proto-proto-type msg)))
 969                             (collect-deserializer
 970                              `((,(make-tag class index))
 971                                (multiple-value-bind (,vval idx)
 972                                      (deserialize-prim ,class ,vbuf ,vidx)
 973                                    (let ((,vval (funcall #',(proto-deserializer msg) ,vval)))
 974                                      (setq ,vidx idx)
 975                                      ,(write-slot vobj field vval)))))))
 976                          (t
 977                           (undefined-field-type "While generating 'deserialize-object' for ~S,"
 978                                                 message class field))))))))
 979       (let* ((rslots  (delete-duplicates rslots :key #'first))
 980              (rfields (mapcar #'first  rslots))
 981              (rtemps  (mapcar #'second rslots)))
 982         `(defmethod deserialize-object
 983              ((,vclass (eql ,message)) ,vbuf &optional ,vidx ,vlen (,vendtag 0))
 984            (declare #.$optimize-serialization)
 985            (declare (type (simple-array (unsigned-byte 8)) ,vbuf))
 986            (let ((,vidx (or ,vidx 0))
 987                  (,vlen (or ,vlen (length ,vbuf))))
 988              (declare (type fixnum ,vidx ,vlen))
 989              (let ((,vobj (make-instance ',(or (proto-alias-for message) (proto-class message))))
 990                    ;; Bind the temporary variables that hold repeated slots
 991                    ,@rtemps)
 992                (loop
 993                  (multiple-value-bind (tag idx)
 994                      (if (i< ,vidx ,vlen) (decode-uint32 ,vbuf ,vidx) (values 0 ,vidx))
 995                    (setq ,vidx idx)
 996                    (when (i= tag ,vendtag)
 997                      ;; Set the (un)reversed values of the repeated slots
 998                      ,@(loop for field in rfields
 999                              for temp in rtemps
1000                              as slot = (proto-value field)
1001                              as writer = (proto-writer field)
1002                              collect (cond ((vector-field-p field)
1003                                             (if writer
1004                                               `(funcall ,writer ,vobj (make-array (length ,temp)
1005                                                                         :fill-pointer t :adjustable t
1006                                                                         :initial-contents (nreverse ,temp)))
1007                                               `(setf (slot-value ,vobj ',slot) (make-array (length ,temp)
1008                                                                                  :fill-pointer t :adjustable t
1009                                                                                  :initial-contents (nreverse ,temp)))))
1010                                            (t
1011                                             (if writer
1012                                               `(funcall ,writer ,vobj (nreverse ,temp))
1013                                               `(setf (slot-value ,vobj ',slot) (nreverse ,temp))))))
1014                      (return-from deserialize-object
1015                        (values ,vobj ,vidx)))
1016                    (case tag
1017                      ,@deserializers
1018                      (otherwise
1019                       (setq ,vidx (skip-element ,vbuf ,vidx tag)))))))))))))
1020
1021 ;; Note well: keep this in sync with the main 'object-size' method above
1022 (defun generate-object-size (message)
1023   "Generate an 'object-size' method for the given message."
1024   (with-gensyms (vobj vsize vval vclass)
1025     (when (null (proto-fields message))
1026       (return-from generate-object-size
1027         `(defmethod object-size
1028              (,vobj (,vclass (eql ,message)) &optional visited)
1029            (declare #.$optimize-serialization)
1030            (setf (cached-object-size ,vobj visited) 0)
1031            0)))
1032     (with-collectors ((sizers collect-sizer))
1033       (dolist (field (proto-fields message))
1034         (let* ((class  (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
1035                (msg    (and class (not (keywordp class))
1036                             (or (find-message message class)
1037                                 (find-enum message class)
1038                                 (find-type-alias message class))))
1039                (reader (cond ((proto-reader field)
1040                               `(,(proto-reader field) ,vobj))
1041                              ((proto-value field)
1042                               `(slot-value ,vobj ',(proto-value field)))))
1043                (index  (proto-index field)))
1044           (when reader
1045             (cond ((eq (proto-required field) :repeated)
1046                    (let* ((vectorp  (vector-field-p field))
1047                           (iterator (if vectorp 'dovector 'dolist)))
1048                      (cond ((and (proto-packed field) (packed-type-p class))
1049                             (collect-sizer
1050                              (let ((tag (make-tag class index)))
1051                                `(iincf ,vsize (packed-size ,reader ,class ,tag ,vectorp)))))
1052                            ((keywordp class)
1053                             (collect-sizer
1054                              (let ((tag (make-tag class index)))
1055                                `(,iterator (,vval ,reader)
1056                                   (iincf ,vsize (prim-size ,vval ,class ,tag))))))
1057                            ((typep msg 'protobuf-message)
1058                             (collect-sizer
1059                              (if (eq (proto-message-type msg) :group)
1060                                (let ((tag1 (make-tag $wire-type-start-group index))
1061                                      (tag2 (make-tag $wire-type-end-group   index)))
1062                                  `(,iterator (,vval ,reader)
1063                                     (let ((len (or (cached-object-size ,vval visited)
1064                                                    (object-size ,vval ,msg visited))))
1065                                       (iincf ,vsize (varint-length ,tag1))
1066                                       (iincf ,vsize len)
1067                                       (iincf ,vsize ,tag2))))
1068                                (let ((tag (make-tag $wire-type-string index)))
1069                                  `(,iterator (,vval ,reader)
1070                                     (let ((len (or (cached-object-size ,vval visited)
1071                                                    (object-size ,vval ,msg visited))))
1072                                       (iincf ,vsize (varint-length ,tag))
1073                                       (iincf ,vsize (varint-length len))
1074                                       (iincf ,vsize len)))))))
1075                            ((typep msg 'protobuf-enum)
1076                             (let ((tag (make-tag $wire-type-varint index)))
1077                               (collect-sizer
1078                                (if (proto-packed field)
1079                                  `(iincf ,vsize (packed-enum-size ,reader '(,@(proto-values msg)) ,tag))
1080                                  `(,iterator (,vval ,reader)
1081                                     (iincf ,vsize (enum-size ,vval '(,@(proto-values msg)) ,tag)))))))
1082                            ((typep msg 'protobuf-type-alias)
1083                             (collect-sizer
1084                              (let* ((class (proto-proto-type msg))
1085                                     (tag   (make-tag class index)))
1086                                `(,iterator (,vval ,reader)
1087                                   (let ((,vval (funcall #',(proto-serializer msg) ,vval)))
1088                                     (iincf ,vsize (prim-size ,vval ,class ,tag)))))))
1089                            (t
1090                             (undefined-field-type "While generating 'object-size' for ~S,"
1091                                                   message class field)))))
1092                   (t
1093                    (cond ((keywordp class)
1094                           (let ((tag (make-tag class index)))
1095                             (collect-sizer
1096                              (if (eq class :bool)
1097                                (if (or (eq (proto-required field) :required)
1098                                        (null (proto-value field)))
1099                                  `(let ((,vval ,reader))
1100                                     (declare (ignorable ,vval))
1101                                     (iincf ,vsize (prim-size ,vval ,class ,tag)))
1102                                  `(let ((,vval (cond ((slot-boundp ,vobj ',(proto-value field))
1103                                                       ,reader)
1104                                                      (t :unbound))))
1105                                     (unless (eq ,vval :unbound)
1106                                       (iincf ,vsize (prim-size ,vval ,class ,tag)))))
1107                                (if (empty-default-p field)
1108                                  `(let ((,vval ,reader))
1109                                     (when ,vval
1110                                       (iincf ,vsize (prim-size ,vval ,class ,tag))))
1111                                  `(let ((,vval ,reader))
1112                                     (when (and ,vval (not (equal ,vval ',(proto-default field))))
1113                                       (iincf ,vsize (prim-size ,vval ,class ,tag)))))))))
1114                          ((typep msg 'protobuf-message)
1115                           (collect-sizer
1116                            (if (eq (proto-message-type msg) :group)
1117                              (let ((tag1 (make-tag $wire-type-start-group index))
1118                                    (tag2 (make-tag $wire-type-end-group   index)))
1119                                `(let ((,vval ,reader))
1120                                   (when ,vval
1121                                     (let ((len (or (cached-object-size ,vval visited)
1122                                                    (object-size ,vval ,msg visited))))
1123                                       (iincf ,vsize (varint-length ,tag1))
1124                                       (iincf ,vsize len)
1125                                       (iincf ,vsize (varint-length ,tag2))))))
1126                              (let ((tag (make-tag $wire-type-string index)))
1127                                `(let ((,vval ,reader))
1128                                   (when ,vval
1129                                     (let ((len (or (cached-object-size ,vval visited)
1130                                                    (object-size ,vval ,msg visited))))
1131                                       (iincf ,vsize (varint-length ,tag))
1132                                       (iincf ,vsize (varint-length len))
1133                                       (iincf ,vsize len))))))))
1134                          ((typep msg 'protobuf-enum)
1135                           (let ((tag (make-tag $wire-type-varint index)))
1136                             (collect-sizer
1137                              (if (empty-default-p field)
1138                                `(let ((,vval ,reader))
1139                                   (when ,vval
1140                                     (iincf ,vsize (enum-size ,vval '(,@(proto-values msg)) ,tag))))
1141                                `(let ((,vval ,reader))
1142                                   (when (and ,vval (not (eql ,vval ',(proto-default field))))
1143                                     (iincf ,vsize (enum-size ,vval '(,@(proto-values msg)) ,tag))))))))
1144                          ((typep msg 'protobuf-type-alias)
1145                           (collect-sizer
1146                            (let* ((class (proto-proto-type msg))
1147                                   (tag   (make-tag class index)))
1148                              `(let ((,vval ,reader))
1149                                 (when ,vval
1150                                   (iincf ,vsize (prim-size (funcall #',(proto-serializer msg) ,vval)
1151                                                            ,class ,tag)))))))
1152                          (t
1153                           (undefined-field-type "While generating 'object-size' for ~S,"
1154                                                 message class field))))))))
1155       `(defmethod object-size
1156            (,vobj (,vclass (eql ,message)) &optional visited)
1157          (declare #.$optimize-serialization)
1158          (declare (ignorable visited))
1159          (let ((,vsize 0))
1160            (declare (type fixnum ,vsize))
1161            ,@sizers
1162            (setf (cached-object-size ,vobj visited) ,vsize)
1163            ,vsize)))))