serialize.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Confidential and proprietary information of ITA Software, Inc.   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012 ITA Software, Inc.  All rights reserved.      ;;;
   6 ;;;                                                                  ;;;
   7 ;;; Original author: Scott McKay                                     ;;;
   8 ;;;                                                                  ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package "PROTO-IMPL")
  12
  13
  14 ;;; Protobuf serialization from Lisp objects
  15
  16 ;;; Serialization
  17
  18 ;; Serialize the object using the given protobuf type
  19 (defun serialize-object-to-stream (object type &key (stream *standard-output*) visited)
  20   "Serializes the object 'object' of type 'type' onto the stream 'stream'
  21    using the wire format.
  22    'type' is the Lisp name of a Protobufs message (usually the name of a
  23    Lisp class) or a 'protobuf-message'.
  24    'visited' is a hash table used to cache object sizes. If it is supplied, it will be
  25    cleared before it is used; otherwise, a fresh table will be created.
  26    The return value is the buffer containing the serialized object. If the stream is
  27    nil, the buffer is not actually written to anywhere."
  28   (let* ((visited (let ((v (or visited (make-hash-table))))
  29                     (clrhash v)
  30                     v))
  31          (size    (object-size object type visited))
  32          (buffer  (make-array size :element-type '(unsigned-byte 8))))
  33     (serialize-object object type buffer 0 visited)
  34     (when stream
  35       (write-sequence buffer stream))
  36     buffer))
  37
  38 (defun serialize-object-to-file (filename object type &key visited)
  39   (with-open-file (stream filename
  40                    :direction :output
  41                    :element-type '(unsigned-byte 8))
  42     (serialize-object-to-stream object type :stream stream :visited visited)))
  43
  44 ;; Allow clients to add their own methods
  45 ;; This is how we address the problem of cycles, e.g. -- if you have an object
  46 ;; that may contain cycles, serialize the cyclic object using a "handle"
  47 (defgeneric serialize-object (object type buffer &optional start visited)
  48   (:documentation
  49    "Serializes the object 'object' of type 'type' into the byte array 'buffer'
  50     using the wire format.
  51     'type' is the Lisp name of a Protobufs message (usually the name of a
  52     Lisp class) or a 'protobuf-message'.
  53     The object is serialized into the byte array given by 'buffer' starting
  54     at the fixnum index 'index' using the wire format.
  55     'visited' is a hash table used to cache object sizes.
  56     The return value is the buffer containing the serialized object."))
  57
  58 (defmethod serialize-object (object (type symbol) buffer &optional start visited)
  59   (let ((message (find-message-for-class type)))
  60     (assert message ()
  61             "There is no Protobuf message having the type ~S" type)
  62     (serialize-object object message buffer start visited)))
  63
  64 ;; 'visited' is used to cache object sizes
  65 ;; If it's passed in explicitly, it is assumed to already have the sizes within it
  66 ;; The default method uses metadata from the protobuf "schema" for the message
  67 (defmethod serialize-object (object (message protobuf-message) buffer &optional start visited)
  68   (declare (type (simple-array (unsigned-byte 8)) buffer))
  69   (let ((visited (or visited (make-hash-table)))
  70         (index   (or start 0)))
  71     (declare (type fixnum index))
  72     (macrolet ((read-slot (object slot reader)
  73                  ;; Don't do a boundp check, we assume the object is fully populated
  74                  ;; Unpopulated slots should be "nullable" and should contain nil
  75                  `(if ,reader
  76                     (funcall ,reader ,object)
  77                     (slot-value ,object ,slot))))
  78       (labels ((do-field (object trace field)
  79                  ;; We don't do cycle detection here
  80                  ;; If the client needs it, he can define his own 'serialize-object'
  81                  ;; method to clean things up first
  82                  (let* ((type   (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
  83                         (slot   (proto-value field))
  84                         (reader (proto-reader field))
  85                         msg)
  86                    (when (or slot reader)
  87                      (cond ((eq (proto-required field) :repeated)
  88                             (cond ((and (proto-packed field) (packed-type-p type))
  89                                    (let ((tag (make-tag type (proto-index field))))
  90                                      (setq index (serialize-packed (read-slot object slot reader)
  91                                                                    type tag buffer index))))
  92                                   ((keywordp type)
  93                                    (let ((tag (make-tag type (proto-index field))))
  94                                      (map () #'(lambda (v)
  95                                                  (setq index (serialize-prim v type tag buffer index)))
  96                                              (read-slot object slot reader))))
  97                                   ((typep (setq msg (and type (or (find-message trace type)
  98                                                                   (find-enum trace type))))
  99                                           'protobuf-message)
 100                                    (dolist (v (if slot (read-slot object slot reader) (list object)))
 101                                      ;; To serialize an embedded message, first say that it's
 102                                      ;; a string, then encode its size, then serialize its fields
 103                                      (let ((tag (make-tag $wire-type-string (proto-index field)))
 104                                            (len (object-size v msg visited)))
 105                                        (setq index (encode-uint32 tag buffer index))
 106                                        (setq index (encode-uint32 len buffer index)))
 107                                      (map () (curry #'do-field v msg)
 108                                              (proto-fields msg))))
 109                                   ((typep msg 'protobuf-enum)
 110                                    (let ((tag (make-tag $wire-type-varint (proto-index field))))
 111                                      (map () #'(lambda (v)
 112                                                  (setq index (serialize-enum v (proto-values msg) tag buffer index)))
 113                                              (read-slot object slot reader))))))
 114                            (t
 115                             (cond ((keywordp type)
 116                                    (let ((v (read-slot object slot reader)))
 117                                      (when (or v (eq type :bool))
 118                                        (let ((tag (make-tag type (proto-index field))))
 119                                          (setq index (serialize-prim v type tag buffer index))))))
 120                                   ((typep (setq msg (and type (or (find-message trace type)
 121                                                                   (find-enum trace type))))
 122                                           'protobuf-message)
 123                                    (let ((v (if slot (read-slot object slot reader) object)))
 124                                      (when v
 125                                        (let ((tag (make-tag $wire-type-string (proto-index field)))
 126                                              (len (object-size v msg visited)))
 127                                          (setq index (encode-uint32 tag buffer index))
 128                                          (setq index (encode-uint32 len buffer index))
 129                                          (map () (curry #'do-field v msg)
 130                                                  (proto-fields msg))))))
 131                                   ((typep msg 'protobuf-enum)
 132                                    (let ((v (read-slot object slot reader)))
 133                                      (when v
 134                                        (let ((tag (make-tag $wire-type-varint (proto-index field))))
 135                                          (setq index (serialize-enum v (proto-values msg) tag buffer index)))))))))))))
 136         (declare (dynamic-extent #'do-field))
 137         (map () (curry #'do-field object message) (proto-fields message))))
 138     (values buffer index)))
 139
 140
 141 ;;; Deserialization
 142
 143 (defun deserialize-object-from-stream (type &key (stream *standard-input*))
 144   "Deserializes an object of the given type 'type' as a Protobuf object.
 145    'type' is the Lisp name of a Protobufs message (usually the name of a
 146    Lisp class) or a 'protobuf-message'.
 147    The return value is the object."
 148   (let* ((size    (file-length stream))
 149          (buffer  (make-array size :element-type '(unsigned-byte 8))))
 150     (read-sequence buffer stream)
 151     (deserialize-object type buffer 0 size)))
 152
 153 (defun deserialize-object-from-file (type filename)
 154   (with-open-file (stream filename
 155                    :direction :input
 156                    :element-type '(unsigned-byte 8))
 157     (deserialize-object-from-stream type :stream stream)))
 158
 159 ;; Allow clients to add their own methods
 160 ;; This is you might preserve object identity, e.g.
 161 (defgeneric deserialize-object (type buffer &optional start end)
 162   (:documentation
 163    "Deserializes an object of the given type 'type' as a Protobufs object.
 164     'type' is the Lisp name of a Protobufs message (usually the name of a
 165     Lisp class) or a 'protobuf-message'.
 166     The encoded bytes are in the byte array given by 'buffer' starting at
 167     the fixnum index 'index' up to the length of the buffer, given by 'length'.
 168     The return values are the object and the index at which deserialization stopped.."))
 169
 170 (defmethod deserialize-object ((type symbol) buffer &optional start end)
 171   (let ((message (find-message-for-class type)))
 172     (assert message ()
 173             "There is no Protobuf message having the type ~S" type)
 174     (deserialize-object message buffer start end)))
 175
 176 ;; The default method uses metadata from the protobuf "schema" for the message
 177 (defmethod deserialize-object ((message protobuf-message) buffer &optional start end)
 178   (declare (type (simple-array (unsigned-byte 8)) buffer))
 179   (let ((index   (or start 0))
 180         (length  (or end (length buffer))))
 181     (declare (type fixnum index length))
 182     (macrolet ((read-slot (object slot reader)
 183                  `(if ,reader
 184                     (funcall ,reader ,object)
 185                     (slot-value ,object ,slot)))
 186                (write-slot (object slot writer value)
 187                  `(if ,writer
 188                     (funcall ,writer ,object ,value)
 189                     (setf (slot-value ,object ,slot) ,value))))
 190       (labels ((deserialize (type trace end)
 191                  (declare (type fixnum end))
 192                  (let* ((message (find-message trace type))
 193                         (object  (and message
 194                                       (make-instance (or (proto-alias-for message) (proto-class message)))))
 195                         ;; All the slots into which we store a repeated element
 196                         (rslots ()))
 197                    (loop
 198                      (multiple-value-bind (tag idx)
 199                          (if (i< index end) (decode-uint32 buffer index) (values 0 index))
 200                        ;; We're done if we've gotten to the end index or
 201                        ;; we see a null byte (there can never be null tags
 202                        ;; because field indices start at 1)
 203                        (when (i= tag 0)
 204                          ;; Now set the repeated slots
 205                          ;; If we do this element by element, we get killed by type checking
 206                          ;; in the slot setters
 207                          (dolist (field rslots)
 208                            (let ((slot   (proto-value field))
 209                                  (reader (proto-reader field))
 210                                  (writer (proto-writer field)))
 211                              (write-slot object slot writer
 212                                          (nreverse (read-slot object slot reader)))))
 213                          (return-from deserialize
 214                            (values object index)))
 215                        (setq index idx)
 216                        (let* ((wtype (ilogand tag #x7))
 217                               (fidx  (ilogand (iash tag -3) #x1FFFFFFF))
 218                               (field (find fidx (proto-fields message) :key #'proto-index))
 219                               (type  (and field (if (eq (proto-class field) 'boolean) :bool (proto-class field))))
 220                               ;; It's OK for this to be null
 221                               ;; That means we're parsing some version of a message
 222                               ;; that has the field, but our current message does not
 223                               ;; We still have to deserialize everything, though
 224                               (slot   (and field (proto-value field)))
 225                               (reader (and field (proto-reader field)))
 226                               (writer (and field (proto-writer field)))
 227                               msg)
 228                          (if (null field)
 229                            ;; If there's no field descriptor for this index, just skip
 230                            ;; the next element in the buffer having the given wire type
 231                            (setq index (skip-element buffer index wtype))
 232                            ;;--- Check for mismatched wire type, running past end of buffer, etc
 233                            (cond ((and field (eq (proto-required field) :repeated))
 234                                   (cond ((and (proto-packed field) (packed-type-p type))
 235                                          (multiple-value-bind (values idx)
 236                                              (deserialize-packed type buffer index)
 237                                            (setq index idx)
 238                                            (when slot
 239                                              (write-slot object slot writer values))))
 240                                         ((keywordp type)
 241                                          (multiple-value-bind (val idx)
 242                                              (deserialize-prim type buffer index)
 243                                            (setq index idx)
 244                                            (when slot
 245                                              (pushnew field rslots)
 246                                              ;; This "push" will type-check the entire list for
 247                                              ;; 'quux:list-of', so avoid using that type in classes
 248                                              ;; in Protobufs if performance is an issue
 249                                              (write-slot object slot writer
 250                                                          (cons val (read-slot object slot reader))))))
 251                                         ((typep (setq msg (and type (or (find-message trace type)
 252                                                                         (find-enum trace type))))
 253                                                 'protobuf-message)
 254                                          (multiple-value-bind (len idx)
 255                                              (decode-uint32 buffer index)
 256                                            (setq index idx)
 257                                            (let ((obj (deserialize type msg (+ index len))))
 258                                              (when slot
 259                                                (pushnew field rslots)
 260                                                (write-slot object slot writer
 261                                                            (cons obj (read-slot object slot reader)))))))
 262                                         ((typep msg 'protobuf-enum)
 263                                          (multiple-value-bind (val idx)
 264                                              (deserialize-enum (proto-values msg) buffer index)
 265                                            (setq index idx)
 266                                            (when slot
 267                                              (pushnew field rslots)
 268                                              (write-slot object slot writer
 269                                                          (cons val (read-slot object slot reader))))))))
 270                                  (t
 271                                   (cond ((keywordp type)
 272                                          (multiple-value-bind (val idx)
 273                                              (deserialize-prim type buffer index)
 274                                            (setq index idx)
 275                                            (when slot
 276                                              (write-slot object slot writer val))))
 277                                         ((typep (setq msg (and type (or (find-message trace type)
 278                                                                         (find-enum trace type))))
 279                                                 'protobuf-message)
 280                                          (multiple-value-bind (len idx)
 281                                              (decode-uint32 buffer index)
 282                                            (setq index idx)
 283                                            (let ((obj (deserialize type msg (+ index len))))
 284                                              (when slot
 285                                                (write-slot object slot writer obj)))))
 286                                         ((typep msg 'protobuf-enum)
 287                                          (multiple-value-bind (val idx)
 288                                              (deserialize-enum (proto-values msg) buffer index)
 289                                            (setq index idx)
 290                                            (when slot
 291                                              (write-slot object slot writer val))))))))))))))
 292         (declare (dynamic-extent #'deserialize))
 293         (deserialize (proto-class message) message length)))))
 294
 295 ;;; Object sizes
 296
 297 ;; Allow clients to add their own methods
 298 ;; This is how we address the problem of cycles, e.g. -- if you have an object
 299 ;; that may contain cycles, return the size of the "handle" to the object
 300 (defgeneric object-size (object type &optional visited)
 301   (:documentation
 302    "Computes the size in bytes of the object 'object' of type 'type'.
 303     'type' is the Lisp name of a Protobufs message (usually the name of a
 304     Lisp class) or a 'protobuf-message'.
 305     'visited' is a hash table used to cache object sizes.
 306     The return value is the size of the object in bytes."))
 307
 308 (defmethod object-size (object (type symbol) &optional visited)
 309   (let ((message (find-message-for-class type)))
 310     (assert message ()
 311             "There is no Protobuf message having the type ~S" type)
 312     (object-size object message visited)))
 313
 314 ;; 'visited' is used to cache object sizes
 315 ;; The default method uses metadata from the protobuf "schema" for the message
 316 (defmethod object-size (object (message protobuf-message) &optional visited)
 317   (let ((size (and visited (gethash object visited))))
 318     (when size
 319       (return-from object-size size)))
 320   (let ((size 0))
 321     (declare (type fixnum size))
 322     (macrolet ((read-slot (object slot reader)
 323                  ;; Don't do a boundp check, we assume the object is fully populated
 324                  ;; Unpopulated slots should be "nullable" and should contain nil
 325                  `(if ,reader
 326                     (funcall ,reader ,object)
 327                     (slot-value ,object ,slot))))
 328       (labels ((do-field (object trace field)
 329                  ;; We don't do cycle detection here
 330                  ;; If the client needs it, he can define his own 'object-size'
 331                  ;; method to clean things up first
 332                  (let* ((type   (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 333                         (slot   (proto-value field))
 334                         (reader (proto-reader field))
 335                         msg)
 336                    (when (or slot reader)
 337                      (cond ((eq (proto-required field) :repeated)
 338                             (cond ((and (proto-packed field) (packed-type-p type))
 339                                    (let ((tag (make-tag type (proto-index field))))
 340                                      (iincf size (packed-size (read-slot object slot reader) type tag))))
 341                                   ((keywordp type)
 342                                    (let ((tag (make-tag type (proto-index field))))
 343                                      (map () #'(lambda (v)
 344                                                  (iincf size (prim-size v type tag)))
 345                                              (read-slot object slot reader))))
 346                                   ((typep (setq msg (and type (or (find-message trace type)
 347                                                                   (find-enum trace type))))
 348                                           'protobuf-message)
 349                                    (dolist (v (if slot (read-slot object slot reader) (list object)))
 350                                      (let ((tag (make-tag $wire-type-string (proto-index field)))
 351                                            (len (object-size v msg visited)))
 352                                        (iincf size (length32 tag))
 353                                        (iincf size (length32 len)))
 354                                      (map () (curry #'do-field v msg)
 355                                              (proto-fields msg))))
 356                                   ((typep msg 'protobuf-enum)
 357                                    (let ((tag (make-tag $wire-type-varint (proto-index field))))
 358                                      (map () #'(lambda (v)
 359                                                  (iincf size (enum-size v (proto-values msg) tag)))
 360                                              (read-slot object slot reader))))))
 361                            (t
 362                             (cond ((keywordp type)
 363                                    (let ((v (read-slot object slot reader)))
 364                                      (when (or v (eq type :bool))
 365                                        (let ((tag (make-tag type (proto-index field))))
 366                                          (iincf size (prim-size v type tag))))))
 367                                   ((typep (setq msg (and type (or (find-message trace type)
 368                                                                   (find-enum trace type))))
 369                                           'protobuf-message)
 370                                    (let ((v (if slot (read-slot object slot reader) object)))
 371                                      (when v
 372                                        (let ((tag (make-tag $wire-type-string (proto-index field)))
 373                                              (len (object-size v msg visited)))
 374                                          (iincf size (length32 tag))
 375                                          (iincf size (length32 len)))
 376                                        (map () (curry #'do-field v msg)
 377                                                (proto-fields msg)))))
 378                                   ((typep msg 'protobuf-enum)
 379                                    (let ((v (read-slot object slot reader)))
 380                                      (when v
 381                                        (let ((tag (make-tag $wire-type-varint (proto-index field))))
 382                                          (iincf size (enum-size (read-slot object slot reader) (proto-values msg) tag)))))))))))))
 383         (declare (dynamic-extent #'do-field))
 384         (map () (curry #'do-field object message) (proto-fields message))
 385         (when visited
 386           (setf (gethash object visited) size))   ;cache the size
 387         size))))
 388
 389 \f
 390 ;;; Compile-time generation of serializers
 391
 392 ;; Note well: keep this in sync with the main 'serialize-object' method above
 393 (defun generate-serializer (message)
 394   "Generate a 'serialize-object' method for the given message."
 395   (with-gensyms (vobj vbuf vidx vval vclass)
 396     (with-collectors ((serializers collect-serializer))
 397       (dolist (field (proto-fields message))
 398         (let* ((class  (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 399                (msg    (and class (not (keywordp class))
 400                             (or (find-message message class)
 401                                 (find-enum message class))))
 402                (reader (cond ((proto-reader field)
 403                               `(,(proto-reader field) ,vobj))
 404                              ((proto-value field)
 405                               `(slot-value ,vobj ',(proto-value field)))))
 406                (index  (proto-index field)))
 407           (when reader
 408             (cond ((eq (proto-required field) :repeated)
 409                    (cond ((and (proto-packed field) (packed-type-p class))
 410                           (collect-serializer
 411                            (let ((tag (make-tag class index)))
 412                              `(setq ,vidx (serialize-packed ,reader ,class ,tag ,vbuf ,vidx)))))
 413                          ((keywordp class)
 414                           (collect-serializer
 415                            (let ((tag (make-tag class index)))
 416                              `(dolist (,vval ,reader)
 417                                 (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))))
 418                          ((typep msg 'protobuf-message)
 419                           (collect-serializer
 420                            (let ((tag (make-tag $wire-type-string index)))
 421                              `(dolist (,vval ,reader)
 422                                 (let ((len (or (and visited (gethash ,vval visited))
 423                                                (object-size ,vval ,msg visited))))
 424                                   (setq ,vidx (encode-uint32 ,tag ,vbuf ,vidx))
 425                                   (setq ,vidx (encode-uint32 len ,vbuf ,vidx))
 426                                   (serialize-object ,vval ,msg ,vbuf ,vidx visited)
 427                                   (iincf ,vidx len))))))
 428                          ((typep msg 'protobuf-enum)
 429                           (collect-serializer
 430                            (let ((tag (make-tag $wire-type-varint index)))
 431                              `(dolist (,vval ,reader)
 432                                 (setq ,vidx (serialize-enum ,vval '(,@(proto-values msg)) ,tag ,vbuf ,vidx))))))))
 433                   (t
 434                    (cond ((keywordp class)
 435                           (collect-serializer
 436                            (let ((tag (make-tag class index)))
 437                              (if (eq class :bool)
 438                                `(let ((,vval ,reader))
 439                                   (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx)))
 440                                `(let ((,vval ,reader))
 441                                   (when ,vval
 442                                     (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))))))
 443                          ((typep msg 'protobuf-message)
 444                           (collect-serializer
 445                            (let ((tag (make-tag $wire-type-string index)))
 446                              `(let ((,vval ,reader))
 447                                 (when ,vval
 448                                   (let ((len (or (and visited (gethash ,vval visited))
 449                                                  (object-size ,vval ,msg visited))))
 450                                     (setq ,vidx (encode-uint32 ,tag ,vbuf ,vidx))
 451                                     (setq ,vidx (encode-uint32 len ,vbuf ,vidx))
 452                                     (serialize-object ,vval ,msg ,vbuf ,vidx visited)
 453                                     (iincf ,vidx len)))))))
 454                          ((typep msg 'protobuf-enum)
 455                           (collect-serializer
 456                            (let ((tag (make-tag $wire-type-varint index)))
 457                              `(let ((,vval ,reader))
 458                                 (when ,vval
 459                                   (setq ,vidx (serialize-enum ,vval '(,@(proto-values msg)) ,tag ,vbuf ,vidx)))))))))))))
 460       `(defmethod serialize-object
 461            (,vobj (,vclass (eql ,message)) ,vbuf &optional (,vidx 0) visited)
 462          (declare (ignorable visited)
 463                   (type (simple-array (unsigned-byte 8)) ,vbuf)
 464                   (type fixnum ,vidx))
 465          (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 466           ,@serializers
 467            (values ,vbuf ,vidx))))))
 468
 469 ;; Note well: keep this in sync with the main 'deserialize-object' method above
 470 (defun generate-deserializer (message)
 471   "Generate a 'deserialize-object' method for the given message."
 472   (with-gensyms (vclass vbuf vidx vlen vobj vval)
 473     (with-collectors ((deserializers collect-deserializer)
 474                       (rslots collect-rslot))
 475       (flet ((read-slot (object field)
 476                (cond ((proto-reader field)
 477                       `(,(proto-reader field) ,object))
 478                      ((proto-value field)
 479                       `(slot-value ,object ',(proto-value field)))))
 480              (write-slot (object field value)
 481                (cond ((proto-writer field)
 482                       `(,(proto-writer field) ,object ,value))
 483                      ((proto-value field)
 484                       `(setf (slot-value ,object ',(proto-value field)) ,value)))))
 485         (dolist (field (proto-fields message))
 486           (let* ((class  (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 487                  (msg    (and class (not (keywordp class))
 488                               (or (find-message message class)
 489                                   (find-enum message class))))
 490                  (index  (proto-index field)))
 491             (cond ((eq (proto-required field) :repeated)
 492                    (cond ((and (proto-packed field) (packed-type-p class))
 493                           (collect-deserializer
 494                            `((,(make-tag class index))
 495                              (multiple-value-bind (,vval idx)
 496                                  (deserialize-packed ,class ,vbuf ,vidx)
 497                                (setq ,vidx idx)
 498                                ,(write-slot vobj field vval)))))
 499                          ((keywordp class)
 500                           (collect-rslot field)
 501                           (collect-deserializer
 502                            `((,(make-tag class index))
 503                              (multiple-value-bind (,vval idx)
 504                                  (deserialize-prim ,class ,vbuf ,vidx)
 505                                (setq ,vidx idx)
 506                                (let ((val ,(read-slot vobj field)))
 507                                  ,(write-slot vobj field `(cons ,vval val)))))))
 508                          ((typep msg 'protobuf-message)
 509                           (collect-rslot field)
 510                           (collect-deserializer
 511                            `((,(make-tag $wire-type-string index))
 512                              ;; Call 'deserialize-object' with the name of the message
 513                              ;; class so that we preferentially get any optimized version
 514                              ;; of the method
 515                              (multiple-value-bind (len idx)
 516                                  (decode-uint32 ,vbuf ,vidx)
 517                                (setq ,vidx idx)
 518                                (multiple-value-bind (,vval idx)
 519                                    (deserialize-object ',class ,vbuf ,vidx (i+ ,vidx len))
 520                                  (setq ,vidx idx)
 521                                  (let ((val ,(read-slot vobj field)))
 522                                    ,(write-slot vobj field `(cons ,vval val))))))))
 523                          ((typep msg 'protobuf-enum)
 524                           (collect-rslot field)
 525                           (collect-deserializer
 526                            `((,(make-tag $wire-type-varint index))
 527                              (multiple-value-bind (,vval idx)
 528                                  (deserialize-enum '(,@(proto-values msg)) ,vbuf ,vidx)
 529                                (setq ,vidx idx)
 530                                (let ((val ,(read-slot vobj field)))
 531                                  ,(write-slot vobj field `(cons ,vval val)))))))))
 532                   (t
 533                    (cond ((keywordp class)
 534                           (collect-deserializer
 535                            `((,(make-tag class index))
 536                              (multiple-value-bind (,vval idx)
 537                                  (deserialize-prim ,class ,vbuf ,vidx)
 538                                (setq ,vidx idx)
 539                                ,(write-slot vobj field vval)))))
 540                          ((typep msg 'protobuf-message)
 541                           (collect-deserializer
 542                            `((,(make-tag $wire-type-string index))
 543                              (multiple-value-bind (len idx)
 544                                  (decode-uint32 ,vbuf ,vidx)
 545                                (setq ,vidx idx)
 546                                (multiple-value-bind (,vval idx)
 547                                    (deserialize-object ',class ,vbuf ,vidx (i+ ,vidx len))
 548                                  (setq ,vidx idx)
 549                                  ,(write-slot vobj field vval))))))
 550                          ((typep msg 'protobuf-enum)
 551                           (collect-deserializer
 552                            `((,(make-tag $wire-type-varint index))
 553                              (multiple-value-bind (,vval idx)
 554                                  (deserialize-enum '(,@(proto-values msg)) ,vbuf ,vidx)
 555                                (setq ,vidx idx)
 556                                ,(write-slot vobj field vval)))))))))))
 557     `(defmethod deserialize-object
 558          ((,vclass (eql ,message)) ,vbuf &optional ,vidx ,vlen)
 559        (declare (type (simple-array (unsigned-byte 8)) ,vbuf))
 560        (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 561          (let ((,vidx (or ,vidx 0))
 562                (,vlen (or ,vlen (length ,vbuf))))
 563            (declare (type fixnum ,vidx ,vlen))
 564            (let ((,vobj (make-instance ',(or (proto-alias-for message) (proto-class message)))))
 565              (loop
 566                (multiple-value-bind (tag idx)
 567                    (if (i< ,vidx ,vlen) (decode-uint32 ,vbuf ,vidx) (values 0 ,vidx))
 568                  (when (i= tag 0)
 569                    (dolist (field ',(delete-duplicates rslots))
 570                      (let* ((slot   (proto-value field))
 571                             (reader (proto-reader field))
 572                             (writer (proto-writer field))
 573                             (value  (nreverse (if reader
 574                                                 (funcall reader ,vobj)
 575                                                 (slot-value ,vobj slot)))))
 576                        (if writer
 577                          (funcall writer ,vobj value)
 578                          (setf (slot-value ,vobj slot) value))))
 579                    (return-from deserialize-object
 580                                 (values ,vobj ,vidx)))
 581                  (setq ,vidx idx)
 582                  (case tag
 583                    ,@deserializers
 584                    (otherwise
 585                     (setq ,vidx (skip-element ,vbuf ,vidx (ilogand tag #x7))))))))))))))
 586
 587 ;; Note well: keep this in sync with the main 'object-size' method above
 588 (defun generate-object-size (message)
 589   "Generate an 'object-size' method for the given message."
 590   (with-gensyms (vobj vsize vval vclass)
 591     (with-collectors ((sizers collect-sizer))
 592       (dolist (field (proto-fields message))
 593         (let* ((class  (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 594                (msg    (and class (not (keywordp class))
 595                             (or (find-message message class)
 596                                 (find-enum message class))))
 597                (reader (cond ((proto-reader field)
 598                               `(,(proto-reader field) ,vobj))
 599                              ((proto-value field)
 600                               `(slot-value ,vobj ',(proto-value field)))))
 601                (index  (proto-index field)))
 602           (when reader
 603             (cond ((eq (proto-required field) :repeated)
 604                    (cond ((and (proto-packed field) (packed-type-p class))
 605                           (collect-sizer
 606                            (let ((tag (make-tag class index)))
 607                              `(iincf ,vsize (packed-size ,reader ,class ,tag)))))
 608                          ((keywordp class)
 609                           (collect-sizer
 610                            (let ((tag (make-tag class index)))
 611                              `(dolist (,vval ,reader)
 612                                 (iincf ,vsize (prim-size ,vval ,class ,tag))))))
 613                          ((typep msg 'protobuf-message)
 614                           (collect-sizer
 615                            (let ((tag (make-tag $wire-type-string index)))
 616                              `(dolist (,vval ,reader)
 617                                 ;; Call 'object-size' with the name of the message
 618                                 ;; class so that we preferentially get any optimized version
 619                                 ;; of the method
 620                                 (let ((len (or (and visited (gethash ,vval visited))
 621                                                (object-size ,vval ,msg visited))))
 622                                   (iincf ,vsize (length32 ,tag))
 623                                   (iincf ,vsize (length32 len))
 624                                   (iincf ,vsize len))))))
 625                          ((typep msg 'protobuf-enum)
 626                           (let ((tag (make-tag $wire-type-varint index)))
 627                             (collect-sizer
 628                              `(dolist (,vval ,reader)
 629                                 (iincf ,vsize (enum-size ,vval '(,@(proto-values msg)) ,tag))))))))
 630                   (t
 631                    (cond ((keywordp class)
 632                           (let ((tag (make-tag class index)))
 633                             (collect-sizer
 634                              (if (eq class :bool)
 635                                `(let ((,vval ,reader))
 636                                   (iincf ,vsize (prim-size ,vval ,class ,tag)))
 637                                `(let ((,vval ,reader))
 638                                   (when ,vval
 639                                     (iincf ,vsize (prim-size ,vval ,class ,tag))))))))
 640                          ((typep msg 'protobuf-message)
 641                           (collect-sizer
 642                            (let ((tag (make-tag $wire-type-string index)))
 643                              `(let ((,vval ,reader))
 644                                 (when ,vval
 645                                   (let ((len (or (and visited (gethash ,vval visited))
 646                                                  (object-size ,vval ,msg visited))))
 647                                     (iincf ,vsize (length32 ,tag))
 648                                     (iincf ,vsize (length32 len))
 649                                     (iincf ,vsize len)))))))
 650                          ((typep msg 'protobuf-enum)
 651                           (let ((tag (make-tag $wire-type-varint index)))
 652                             (collect-sizer
 653                              `(let ((,vval ,reader))
 654                                 (when ,vval
 655                                   (iincf ,vsize (enum-size ,vval '(,@(proto-values msg)) ,tag)))))))))))))
 656       `(defmethod object-size
 657            (,vobj (,vclass (eql ,message)) &optional visited)
 658          (declare (ignorable visited))
 659          (locally (declare (optimize (speed 3) (safety 0) (debug 0)))
 660            (let ((,vsize (and visited (gethash ,vobj visited))))
 661              (when ,vsize
 662                (return-from object-size ,vsize)))
 663            (let ((,vsize 0))
 664              (declare (type fixnum ,vsize))
 665              ,@sizers
 666              (when visited
 667                (setf (gethash ,vobj visited) ,vsize))
 668              ,vsize))))))