serialize.lisp

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