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 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                                    (if (eq (proto-message-type msg) :group)
 101                                      (dolist (v (if slot (read-slot object slot reader) (list object)))
 102                                        ;; To serialize a group, we encode a start tag,
 103                                        ;; serialize the fields, then encode an end tag
 104                                        (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
 105                                              (tag2 (make-tag $wire-type-end-group   (proto-index field))))
 106                                          (setq index (encode-uint32 tag1 buffer index))
 107                                          (map () (curry #'do-field v msg)
 108                                                  (proto-fields msg))
 109                                          (setq index (encode-uint32 tag2 buffer index))))
 110                                      (dolist (v (if slot (read-slot object slot reader) (list object)))
 111                                        ;; To serialize an embedded message, first say that it's
 112                                        ;; a string, then encode its size, then serialize its fields
 113                                        (let ((tag (make-tag $wire-type-string (proto-index field)))
 114                                              (len (object-size v msg visited)))
 115                                          (setq index (encode-uint32 tag buffer index))
 116                                          (setq index (encode-uint32 len buffer index)))
 117                                        (map () (curry #'do-field v msg)
 118                                                (proto-fields msg)))))
 119                                   ((typep msg 'protobuf-enum)
 120                                    (let ((tag (make-tag $wire-type-varint (proto-index field))))
 121                                      (map () #'(lambda (v)
 122                                                  (setq index (serialize-enum v (proto-values msg) tag buffer index)))
 123                                              (read-slot object slot reader))))))
 124                            (t
 125                             (cond ((eq type :bool)
 126                                    ;; We have to handle optional boolean fields specially
 127                                    ;; because "false" and nil are the same value in Lisp
 128                                    (let ((v (cond ((or (eq (proto-required field) :required)
 129                                                        (null slot))
 130                                                    (read-slot object slot reader))
 131                                                   ((slot-boundp object slot)
 132                                                    (read-slot object slot reader))
 133                                                   (t :unbound))))
 134                                      (unless (eq v :unbound)
 135                                        (let ((tag (make-tag :bool (proto-index field))))
 136                                          (setq index (serialize-prim v type tag buffer index))))))
 137                                   ((keywordp type)
 138                                    (let ((v (read-slot object slot reader)))
 139                                      (when v
 140                                        (let ((tag (make-tag type (proto-index field))))
 141                                          (setq index (serialize-prim v type tag buffer index))))))
 142                                   ((typep (setq msg (and type (or (find-message trace type)
 143                                                                   (find-enum trace type))))
 144                                           'protobuf-message)
 145                                    (let ((v (if slot (read-slot object slot reader) object)))
 146                                      (when v
 147                                        (if (eq (proto-message-type msg) :group)
 148                                          (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
 149                                                (tag2 (make-tag $wire-type-end-group   (proto-index field))))
 150                                            (setq index (encode-uint32 tag1 buffer index))
 151                                            (map () (curry #'do-field v msg)
 152                                                    (proto-fields msg))
 153                                            (setq index (encode-uint32 tag2 buffer index)))
 154                                          (let ((tag (make-tag $wire-type-string (proto-index field)))
 155                                                (len (object-size v msg visited)))
 156                                            (setq index (encode-uint32 tag buffer index))
 157                                            (setq index (encode-uint32 len buffer index))
 158                                            (map () (curry #'do-field v msg)
 159                                                    (proto-fields msg)))))))
 160                                   ((typep msg 'protobuf-enum)
 161                                    (let ((v (read-slot object slot reader)))
 162                                      (when v
 163                                        (let ((tag (make-tag $wire-type-varint (proto-index field))))
 164                                          (setq index (serialize-enum v (proto-values msg) tag buffer index)))))))))))))
 165         (declare (dynamic-extent #'do-field))
 166         (map () (curry #'do-field object message) (proto-fields message))))
 167     (values buffer index)))
 168
 169
 170 ;;; Deserialization
 171
 172 (defun deserialize-object-from-stream (type &key (stream *standard-input*))
 173   "Deserializes an object of the given type 'type' as a Protobuf object.
 174    'type' is the Lisp name of a Protobufs message (usually the name of a
 175    Lisp class) or a 'protobuf-message'.
 176    The return value is the object."
 177   (let* ((size    (file-length stream))
 178          (buffer  (make-array size :element-type '(unsigned-byte 8))))
 179     (read-sequence buffer stream)
 180     (deserialize-object type buffer 0 size)))
 181
 182 (defun deserialize-object-from-file (type filename)
 183   (with-open-file (stream filename
 184                    :direction :input
 185                    :element-type '(unsigned-byte 8))
 186     (deserialize-object-from-stream type :stream stream)))
 187
 188 ;; Allow clients to add their own methods
 189 ;; This is you might preserve object identity, e.g.
 190 (defgeneric deserialize-object (type buffer &optional start end end-tag)
 191   (:documentation
 192    "Deserializes an object of the given type 'type' as a Protobufs object.
 193     'type' is the Lisp name of a Protobufs message (usually the name of a
 194     Lisp class) or a 'protobuf-message'.
 195     The encoded bytes are in the byte array given by 'buffer' starting at
 196     the fixnum index 'start' up to the end of the buffer, given by 'end'.
 197     'start' defaults to 0, 'end' defaults to the length of the buffer.
 198     'end-tag' is used internally to handle the (deprecated) \"group\" feature.
 199     The return values are the object and the index at which deserialization stopped.."))
 200
 201 (defmethod deserialize-object (type buffer &optional start end (end-tag 0))
 202   (let ((message (find-message-for-class type)))
 203     (assert message ()
 204             "There is no Protobuf message having the type ~S" type)
 205     (deserialize-object message buffer start end end-tag)))
 206
 207 ;; The default method uses metadata from the protobuf "schema" for the message
 208 (defmethod deserialize-object ((message protobuf-message) buffer &optional start end (end-tag 0))
 209   (declare (type (simple-array (unsigned-byte 8)) buffer))
 210   (let ((index   (or start 0))
 211         (length  (or end (length buffer))))
 212     (declare (type fixnum index length))
 213     (macrolet ((read-slot (object slot reader)
 214                  `(if ,reader
 215                     (funcall ,reader ,object)
 216                     (slot-value ,object ,slot)))
 217                (write-slot (object slot writer value)
 218                  (with-gensyms (vval)
 219                    `(let ((,vval ,value))
 220                       (if ,writer
 221                         (funcall ,writer ,object ,vval)
 222                         (setf (slot-value ,object ,slot) ,vval))))))
 223       (labels ((deserialize (type trace end end-tag)
 224                  (declare (type fixnum end end-tag))
 225                  (let* ((message (find-message trace type))
 226                         (object  (and message
 227                                       (make-instance (or (proto-alias-for message) (proto-class message)))))
 228                         ;; All the slots into which we store a repeated element
 229                         ;; These will be reversed at the end of deserialization
 230                         (rslots ()))
 231                    (loop
 232                      (multiple-value-bind (tag idx)
 233                          (if (i< index end) (decode-uint32 buffer index) (values 0 index))
 234                        ;; We're done if we've gotten to the end index or
 235                        ;; we see an end tag that matches a previous group's start tag
 236                        ;; Note that the default end tag is 0, which is also an end of
 237                        ;; message marker (there can never be "real" zero tags because
 238                        ;; field indices start at 1)
 239                        (setq index idx)
 240                        (when (i= tag end-tag)
 241                          ;; Reverse the repeated slots
 242                          (dolist (field rslots)
 243                            (let ((slot   (proto-value field))
 244                                  (reader (proto-reader field))
 245                                  (writer (proto-writer field)))
 246                              (write-slot object slot writer
 247                                          (nreverse (read-slot object slot reader)))))
 248                          (return-from deserialize
 249                            (values object index)))
 250                        (let* ((fidx  (ilogand (iash tag -3) #x1FFFFFFF))
 251                               (field (find fidx (proto-fields message) :key #'proto-index))
 252                               (type  (and field (if (eq (proto-class field) 'boolean) :bool (proto-class field))))
 253                               ;; It's OK for this to be null
 254                               ;; That means we're parsing some version of a message
 255                               ;; that has the field, but our current message does not
 256                               ;; We still have to deserialize everything, though
 257                               (slot   (and field (proto-value field)))
 258                               (reader (and field (proto-reader field)))
 259                               (writer (and field (proto-writer field)))
 260                               msg)
 261                          (if (null field)
 262                            ;; If there's no field descriptor for this index, just skip
 263                            ;; the next element in the buffer having the given wire type
 264                            (setq index (skip-element buffer index tag))
 265                            ;;--- Check for mismatched wire type, running past end of buffer, etc
 266                            (cond ((and field (eq (proto-required field) :repeated))
 267                                   (cond ((and (proto-packed field) (packed-type-p type))
 268                                          (multiple-value-bind (values idx)
 269                                              (deserialize-packed type buffer index)
 270                                            (setq index idx)
 271                                            (write-slot object slot writer values)))
 272                                         ((keywordp type)
 273                                          (multiple-value-bind (val idx)
 274                                              (deserialize-prim type buffer index)
 275                                            (setq index idx)
 276                                            (pushnew field rslots)
 277                                            ;; This "push" will type-check the entire list for
 278                                            ;; 'quux:list-of', so avoid using that type in classes
 279                                            ;; in Protobufs if performance is an issue
 280                                            ;; We'll reverse the slots at the last minute
 281                                            (write-slot object slot writer
 282                                                        (cons val (read-slot object slot reader)))))
 283                                         ((typep (setq msg (and type (or (find-message trace type)
 284                                                                         (find-enum trace type))))
 285                                                 'protobuf-message)
 286                                          (if (eq (proto-message-type msg) :group)
 287                                            (let* ((etag (make-tag $wire-type-end-group fidx))
 288                                                   (obj  (deserialize type msg length etag)))
 289                                              (pushnew field rslots)
 290                                              (write-slot object slot writer
 291                                                          (cons obj (read-slot object slot reader))))
 292                                            (multiple-value-bind (len idx)
 293                                                (decode-uint32 buffer index)
 294                                              (setq index idx)
 295                                              (let ((obj (deserialize type msg (+ index len) 0)))
 296                                                (pushnew field rslots)
 297                                                (write-slot object slot writer
 298                                                            (cons obj (read-slot object slot reader)))))))
 299                                         ((typep msg 'protobuf-enum)
 300                                          (multiple-value-bind (val idx)
 301                                              (deserialize-enum (proto-values msg) buffer index)
 302                                            (setq index idx)
 303                                            (pushnew field rslots)
 304                                            (write-slot object slot writer
 305                                                        (cons val (read-slot object slot reader)))))))
 306                                  (t
 307                                   (cond ((keywordp type)
 308                                          (multiple-value-bind (val idx)
 309                                              (deserialize-prim type buffer index)
 310                                            (setq index idx)
 311                                            (write-slot object slot writer val)))
 312                                         ((typep (setq msg (and type (or (find-message trace type)
 313                                                                         (find-enum trace type))))
 314                                                 'protobuf-message)
 315                                          ;;--- If there's already a value in the slot, merge messages
 316                                          (if (eq (proto-message-type msg) :group)
 317                                            (let* ((etag (make-tag $wire-type-end-group fidx))
 318                                                   (obj  (deserialize type msg length etag)))
 319                                              (write-slot object slot writer obj))
 320                                            (multiple-value-bind (len idx)
 321                                                (decode-uint32 buffer index)
 322                                              (setq index idx)
 323                                              (let ((obj (deserialize type msg (+ index len) 0)))
 324                                                (write-slot object slot writer obj)))))
 325                                         ((typep msg 'protobuf-enum)
 326                                          (multiple-value-bind (val idx)
 327                                              (deserialize-enum (proto-values msg) buffer index)
 328                                            (setq index idx)
 329                                            (write-slot object slot writer val)))))))))))))
 330         (declare (dynamic-extent #'deserialize))
 331         (deserialize (proto-class message) message length end-tag)))))
 332
 333 ;;; Object sizes
 334
 335 ;; Allow clients to add their own methods
 336 ;; This is how we address the problem of cycles, e.g. -- if you have an object
 337 ;; that may contain cycles, return the size of the "handle" to the object
 338 (defgeneric object-size (object type &optional visited)
 339   (:documentation
 340    "Computes the size in bytes of the object 'object' of type 'type'.
 341     'type' is the Lisp name of a Protobufs message (usually the name of a
 342     Lisp class) or a 'protobuf-message'.
 343     'visited' is a hash table used to cache object sizes.
 344     The return value is the size of the object in bytes."))
 345
 346 (defmethod object-size (object type &optional visited)
 347   (let ((message (find-message-for-class type)))
 348     (assert message ()
 349             "There is no Protobuf message having the type ~S" type)
 350     (object-size object message visited)))
 351
 352 ;; 'visited' is used to cache object sizes
 353 ;; The default method uses metadata from the protobuf "schema" for the message
 354 (defmethod object-size (object (message protobuf-message) &optional visited)
 355   (let ((size (and visited (gethash object visited))))
 356     (when size
 357       (return-from object-size size)))
 358   (let ((size 0))
 359     (declare (type fixnum size))
 360     (macrolet ((read-slot (object slot reader)
 361                  ;; Don't do a boundp check, we assume the object is fully populated
 362                  ;; Unpopulated slots should be "nullable" and should contain nil
 363                  `(if ,reader
 364                     (funcall ,reader ,object)
 365                     (slot-value ,object ,slot))))
 366       (labels ((do-field (object trace field)
 367                  ;; We don't do cycle detection here
 368                  ;; If the client needs it, he can define his own 'object-size'
 369                  ;; method to clean things up first
 370                  (let* ((type   (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 371                         (slot   (proto-value field))
 372                         (reader (proto-reader field))
 373                         msg)
 374                    (when (or slot reader)
 375                      (cond ((eq (proto-required field) :repeated)
 376                             (cond ((and (proto-packed field) (packed-type-p type))
 377                                    (let ((tag (make-tag type (proto-index field))))
 378                                      (iincf size (packed-size (read-slot object slot reader) type tag))))
 379                                   ((keywordp type)
 380                                    (let ((tag (make-tag type (proto-index field))))
 381                                      (map () #'(lambda (v)
 382                                                  (iincf size (prim-size v type tag)))
 383                                              (read-slot object slot reader))))
 384                                   ((typep (setq msg (and type (or (find-message trace type)
 385                                                                   (find-enum trace type))))
 386                                           'protobuf-message)
 387                                    (if (eq (proto-message-type msg) :group)
 388                                      (dolist (v (if slot (read-slot object slot reader) (list object)))
 389                                        (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
 390                                              (tag2 (make-tag $wire-type-end-group   (proto-index field))))
 391                                          (iincf size (length32 tag1))
 392                                          (map () (curry #'do-field v msg)
 393                                                  (proto-fields msg))
 394                                          (iincf size (length32 tag2))))
 395                                      (dolist (v (if slot (read-slot object slot reader) (list object)))
 396                                        (let ((tag (make-tag $wire-type-string (proto-index field)))
 397                                              (len (object-size v msg visited)))
 398                                          (iincf size (length32 tag))
 399                                          (iincf size (length32 len))
 400                                          (map () (curry #'do-field v msg)
 401                                                  (proto-fields msg))))))
 402                                   ((typep msg 'protobuf-enum)
 403                                    (let ((tag (make-tag $wire-type-varint (proto-index field))))
 404                                      (map () #'(lambda (v)
 405                                                  (iincf size (enum-size v (proto-values msg) tag)))
 406                                              (read-slot object slot reader))))))
 407                            (t
 408                             (cond ((eq type :bool)
 409                                    (let ((v (cond ((or (eq (proto-required field) :required)
 410                                                        (null slot))
 411                                                    (read-slot object slot reader))
 412                                                   ((slot-boundp object slot)
 413                                                    (read-slot object slot reader))
 414                                                   (t :unbound))))
 415                                      (unless (eq v :unbound)
 416                                        (let ((tag (make-tag :bool (proto-index field))))
 417                                          (iincf size (prim-size v type tag))))))
 418                                   ((keywordp type)
 419                                    (let ((v (read-slot object slot reader)))
 420                                      (when v
 421                                        (let ((tag (make-tag type (proto-index field))))
 422                                          (iincf size (prim-size v type tag))))))
 423                                   ((typep (setq msg (and type (or (find-message trace type)
 424                                                                   (find-enum trace type))))
 425                                           'protobuf-message)
 426                                    (let ((v (if slot (read-slot object slot reader) object)))
 427                                      (when v
 428                                        (if (eq (proto-message-type msg) :group)
 429                                          (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
 430                                              (tag2 (make-tag $wire-type-end-group   (proto-index field))))
 431                                            (iincf size (length32 tag1))
 432                                            (map () (curry #'do-field v msg)
 433                                                    (proto-fields msg))
 434                                            (iincf size (length32 tag2)))
 435                                          (let ((tag (make-tag $wire-type-string (proto-index field)))
 436                                                (len (object-size v msg visited)))
 437                                            (iincf size (length32 tag))
 438                                            (iincf size (length32 len))
 439                                            (map () (curry #'do-field v msg)
 440                                                 (proto-fields msg)))))))
 441                                   ((typep msg 'protobuf-enum)
 442                                    (let ((v (read-slot object slot reader)))
 443                                      (when v
 444                                        (let ((tag (make-tag $wire-type-varint (proto-index field))))
 445                                          (iincf size (enum-size (read-slot object slot reader) (proto-values msg) tag)))))))))))))
 446         (declare (dynamic-extent #'do-field))
 447         (map () (curry #'do-field object message) (proto-fields message))
 448         (when visited
 449           (setf (gethash object visited) size))   ;cache the size
 450         size))))
 451
 452 \f
 453 ;;; Compile-time generation of serializers
 454 ;;; Type-checking is done at the top-level methods specialized on 'symbol',
 455 ;;; so we turn off all type checking at the level of these functions
 456
 457 ;; Note well: keep this in sync with the main 'serialize-object' method above
 458 (defun generate-serializer (message)
 459   "Generate a 'serialize-object' method for the given message."
 460   (with-gensyms (vobj vbuf vidx vval vclass)
 461     (with-collectors ((serializers collect-serializer))
 462       (dolist (field (proto-fields message))
 463         (let* ((class  (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 464                (msg    (and class (not (keywordp class))
 465                             (or (find-message message class)
 466                                 (find-enum message class))))
 467                (reader (cond ((proto-reader field)
 468                               `(,(proto-reader field) ,vobj))
 469                              ((proto-value field)
 470                               `(slot-value ,vobj ',(proto-value field)))))
 471                (index  (proto-index field)))
 472           (when reader
 473             (cond ((eq (proto-required field) :repeated)
 474                    (cond ((and (proto-packed field) (packed-type-p class))
 475                           (collect-serializer
 476                            (let ((tag (make-tag class index)))
 477                              `(setq ,vidx (serialize-packed ,reader ,class ,tag ,vbuf ,vidx)))))
 478                          ((keywordp class)
 479                           (collect-serializer
 480                            (let ((tag (make-tag class index)))
 481                              `(dolist (,vval ,reader)
 482                                 (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))))
 483                          ((typep msg 'protobuf-message)
 484                           (collect-serializer
 485                            (if (eq (proto-message-type msg) :group)
 486                              (let ((tag1 (make-tag $wire-type-start-group index))
 487                                    (tag2 (make-tag $wire-type-end-group   index)))
 488                                `(dolist (,vval ,reader)
 489                                   (let ((len (or (and visited (gethash ,vval visited))
 490                                                  (object-size ,vval ,msg visited))))
 491                                     (setq ,vidx (encode-uint32 ,tag1 ,vbuf ,vidx))
 492                                     (serialize-object ,vval ,msg ,vbuf ,vidx visited)
 493                                     (iincf ,vidx len)
 494                                     (setq ,vidx (encode-uint32 ,tag2 ,vbuf ,vidx)))))
 495                              (let ((tag (make-tag $wire-type-string index)))
 496                                `(dolist (,vval ,reader)
 497                                   (let ((len (or (and visited (gethash ,vval visited))
 498                                                  (object-size ,vval ,msg visited))))
 499                                     (setq ,vidx (encode-uint32 ,tag ,vbuf ,vidx))
 500                                     (setq ,vidx (encode-uint32 len ,vbuf ,vidx))
 501                                     (serialize-object ,vval ,msg ,vbuf ,vidx visited)
 502                                     (iincf ,vidx len)))))))
 503                          ((typep msg 'protobuf-enum)
 504                           (collect-serializer
 505                            (let ((tag (make-tag $wire-type-varint index)))
 506                              `(dolist (,vval ,reader)
 507                                 (setq ,vidx (serialize-enum ,vval '(,@(proto-values msg)) ,tag ,vbuf ,vidx))))))))
 508                   (t
 509                    (cond ((keywordp class)
 510                           (collect-serializer
 511                            (let ((tag (make-tag class index)))
 512                              (if (eq class :bool)
 513                                (if (or (eq (proto-required field) :required)
 514                                        (null (proto-value field)))
 515                                  `(let ((,vval ,reader))
 516                                     (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx)))
 517                                  `(let ((,vval (cond ((slot-boundp ,vobj ',(proto-value field))
 518                                                       ,reader)
 519                                                      (t :unbound))))
 520                                     (unless (eq ,vval :unbound)
 521                                       (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx)))))
 522                                `(let ((,vval ,reader))
 523                                   (when ,vval
 524                                     (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))))))
 525                          ((typep msg 'protobuf-message)
 526                           (collect-serializer
 527                            (if (eq (proto-message-type msg) :group)
 528                              (let ((tag1 (make-tag $wire-type-start-group index))
 529                                    (tag2 (make-tag $wire-type-end-group   index)))
 530                                `(let ((,vval ,reader))
 531                                   (when ,vval
 532                                     (let ((len (or (and visited (gethash ,vval visited))
 533                                                    (object-size ,vval ,msg visited))))
 534                                       (setq ,vidx (encode-uint32 ,tag1 ,vbuf ,vidx))
 535                                       (serialize-object ,vval ,msg ,vbuf ,vidx visited)
 536                                       (iincf ,vidx len)
 537                                       (setq ,vidx (encode-uint32 ,tag2 ,vbuf ,vidx))))))
 538                              (let ((tag (make-tag $wire-type-string index)))
 539                                `(let ((,vval ,reader))
 540                                   (when ,vval
 541                                     (let ((len (or (and visited (gethash ,vval visited))
 542                                                    (object-size ,vval ,msg visited))))
 543                                       (setq ,vidx (encode-uint32 ,tag ,vbuf ,vidx))
 544                                       (setq ,vidx (encode-uint32 len ,vbuf ,vidx))
 545                                       (serialize-object ,vval ,msg ,vbuf ,vidx visited)
 546                                       (iincf ,vidx len))))))))
 547                          ((typep msg 'protobuf-enum)
 548                           (collect-serializer
 549                            (let ((tag (make-tag $wire-type-varint index)))
 550                              `(let ((,vval ,reader))
 551                                 (when ,vval
 552                                   (setq ,vidx (serialize-enum ,vval '(,@(proto-values msg)) ,tag ,vbuf ,vidx)))))))))))))
 553       `(defmethod serialize-object
 554            (,vobj (,vclass (eql ,message)) ,vbuf &optional (,vidx 0) visited)
 555          (declare (optimize (speed 3) (safety 0) (debug 0)))
 556          (declare (ignorable visited)
 557                   (type (simple-array (unsigned-byte 8)) ,vbuf)
 558                   (type fixnum ,vidx))
 559          ,@serializers
 560          (values ,vbuf ,vidx)))))
 561
 562 ;; Note well: keep this in sync with the main 'deserialize-object' method above
 563 (defun generate-deserializer (message)
 564   "Generate a 'deserialize-object' method for the given message."
 565   (with-gensyms (vclass vbuf vidx vlen vendtag vobj vval)
 566     (with-collectors ((deserializers collect-deserializer)
 567                       ;; For tracking repeated slots that will need to be reversed
 568                       (rslots collect-rslot))
 569       (flet ((read-slot (object field)
 570                (cond ((proto-reader field)
 571                       `(,(proto-reader field) ,object))
 572                      ((proto-value field)
 573                       `(slot-value ,object ',(proto-value field)))))
 574              (write-slot (object field value)
 575                (cond ((proto-writer field)
 576                       `(,(proto-writer field) ,object ,value))
 577                      ((proto-value field)
 578                       `(setf (slot-value ,object ',(proto-value field)) ,value)))))
 579         (dolist (field (proto-fields message))
 580           (let* ((class  (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 581                  (msg    (and class (not (keywordp class))
 582                               (or (find-message message class)
 583                                   (find-enum message class))))
 584                  (index  (proto-index field)))
 585             (cond ((eq (proto-required field) :repeated)
 586                    (cond ((and (proto-packed field) (packed-type-p class))
 587                           (collect-deserializer
 588                            `((,(make-tag class index))
 589                              (multiple-value-bind (,vval idx)
 590                                  (deserialize-packed ,class ,vbuf ,vidx)
 591                                (setq ,vidx idx)
 592                                ,(write-slot vobj field vval)))))
 593                          ((keywordp class)
 594                           (let ((temp (gensym (string (proto-value field)))))
 595                             (collect-rslot (list field temp))
 596                             (collect-deserializer
 597                              `((,(make-tag class index))
 598                                (multiple-value-bind (,vval idx)
 599                                    (deserialize-prim ,class ,vbuf ,vidx)
 600                                  (setq ,vidx idx)
 601                                  (push ,vval ,temp))))))
 602                          ((typep msg 'protobuf-message)
 603                           (let ((temp (gensym (string (proto-value field)))))
 604                             (collect-rslot (list field temp))
 605                             (collect-deserializer
 606                              (if (eq (proto-message-type msg) :group)
 607                                `((,(make-tag $wire-type-start-group index))
 608                                  (multiple-value-bind (,vval idx)
 609                                      (deserialize-object ,msg ,vbuf ,vidx ,vlen
 610                                                          ,(make-tag $wire-type-end-group index))
 611                                    (setq ,vidx idx)
 612                                    (push ,vval ,temp)))
 613                                `((,(make-tag $wire-type-string index))
 614                                  (multiple-value-bind (len idx)
 615                                      (decode-uint32 ,vbuf ,vidx)
 616                                    (setq ,vidx idx)
 617                                    (multiple-value-bind (,vval idx)
 618                                        (deserialize-object ,msg ,vbuf ,vidx (i+ ,vidx len) 0)
 619                                      (setq ,vidx idx)
 620                                      (push ,vval ,temp))))))))
 621                          ((typep msg 'protobuf-enum)
 622                           (let ((temp (gensym (string (proto-value field)))))
 623                             (collect-rslot (list field temp))
 624                             (collect-deserializer
 625                              `((,(make-tag $wire-type-varint index))
 626                                (multiple-value-bind (,vval idx)
 627                                    (deserialize-enum '(,@(proto-values msg)) ,vbuf ,vidx)
 628                                  (setq ,vidx idx)
 629                                  (push ,vval ,temp))))))))
 630                   (t
 631                    (cond ((keywordp class)
 632                           (collect-deserializer
 633                            `((,(make-tag class index))
 634                              (multiple-value-bind (,vval idx)
 635                                  (deserialize-prim ,class ,vbuf ,vidx)
 636                                (setq ,vidx idx)
 637                                ,(write-slot vobj field vval)))))
 638                          ((typep msg 'protobuf-message)
 639                           (collect-deserializer
 640                            (if (eq (proto-message-type msg) :group)
 641                              `((,(make-tag $wire-type-start-group index))
 642                                (multiple-value-bind (,vval idx)
 643                                    (deserialize-object ,msg ,vbuf ,vidx  ,vlen
 644                                                        ,(make-tag $wire-type-end-group index))
 645                                  (setq ,vidx idx)
 646                                  ,(write-slot vobj field vval)))
 647                              `((,(make-tag $wire-type-string index))
 648                                (multiple-value-bind (len idx)
 649                                    (decode-uint32 ,vbuf ,vidx)
 650                                  (setq ,vidx idx)
 651                                  (multiple-value-bind (,vval idx)
 652                                      (deserialize-object ,msg ,vbuf ,vidx (i+ ,vidx len) 0)
 653                                    (setq ,vidx idx)
 654                                    ,(write-slot vobj field vval)))))))
 655                          ((typep msg 'protobuf-enum)
 656                           (collect-deserializer
 657                            `((,(make-tag $wire-type-varint index))
 658                              (multiple-value-bind (,vval idx)
 659                                  (deserialize-enum '(,@(proto-values msg)) ,vbuf ,vidx)
 660                                (setq ,vidx idx)
 661                                ,(write-slot vobj field vval)))))))))))
 662       (let* ((rslots  (delete-duplicates rslots :key #'first))
 663              (rfields (mapcar #'first  rslots))
 664              (rtemps  (mapcar #'second rslots)))
 665         `(defmethod deserialize-object
 666              ((,vclass (eql ,message)) ,vbuf &optional ,vidx ,vlen (,vendtag 0))
 667            (declare (optimize (speed 3) (safety 0) (debug 0)))
 668            (declare (type (simple-array (unsigned-byte 8)) ,vbuf))
 669            (let ((,vidx (or ,vidx 0))
 670                  (,vlen (or ,vlen (length ,vbuf))))
 671              (declare (type fixnum ,vidx ,vlen))
 672              (let ((,vobj (make-instance ',(or (proto-alias-for message) (proto-class message))))
 673                    ;; Bind the temporary variables that hold repeated slots
 674                    ,@rtemps)
 675                (loop
 676                  (multiple-value-bind (tag idx)
 677                      (if (i< ,vidx ,vlen) (decode-uint32 ,vbuf ,vidx) (values 0 ,vidx))
 678                    (setq ,vidx idx)
 679                    (when (i= tag ,vendtag)
 680                      ;; Set the (un)reversed values of the repeated slots
 681                      ,@(loop for field in rfields
 682                              for temp in rtemps
 683                              as slot = (proto-value field)
 684                              as writer = (proto-writer field)
 685                              collect (if writer
 686                                        `(funcall ,writer ,vobj (nreverse ,temp))
 687                                        `(setf (slot-value ,vobj ',slot) (nreverse ,temp))))
 688                      (return-from deserialize-object
 689                        (values ,vobj ,vidx)))
 690                    (case tag
 691                      ,@deserializers
 692                      (otherwise
 693                       (setq ,vidx (skip-element ,vbuf ,vidx tag)))))))))))))
 694
 695 ;; Note well: keep this in sync with the main 'object-size' method above
 696 (defun generate-object-size (message)
 697   "Generate an 'object-size' method for the given message."
 698   (with-gensyms (vobj vsize vval vclass)
 699     (with-collectors ((sizers collect-sizer))
 700       (dolist (field (proto-fields message))
 701         (let* ((class  (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 702                (msg    (and class (not (keywordp class))
 703                             (or (find-message message class)
 704                                 (find-enum message class))))
 705                (reader (cond ((proto-reader field)
 706                               `(,(proto-reader field) ,vobj))
 707                              ((proto-value field)
 708                               `(slot-value ,vobj ',(proto-value field)))))
 709                (index  (proto-index field)))
 710           (when reader
 711             (cond ((eq (proto-required field) :repeated)
 712                    (cond ((and (proto-packed field) (packed-type-p class))
 713                           (collect-sizer
 714                            (let ((tag (make-tag class index)))
 715                              `(iincf ,vsize (packed-size ,reader ,class ,tag)))))
 716                          ((keywordp class)
 717                           (collect-sizer
 718                            (let ((tag (make-tag class index)))
 719                              `(dolist (,vval ,reader)
 720                                 (iincf ,vsize (prim-size ,vval ,class ,tag))))))
 721                          ((typep msg 'protobuf-message)
 722                           (collect-sizer
 723                            (if (eq (proto-message-type msg) :group)
 724                              (let ((tag1 (make-tag $wire-type-start-group index))
 725                                    (tag2 (make-tag $wire-type-end-group   index)))
 726                                `(dolist (,vval ,reader)
 727                                   (let ((len (or (and visited (gethash ,vval visited))
 728                                                  (object-size ,vval ,msg visited))))
 729                                     (iincf ,vsize (length32 ,tag1))
 730                                     (iincf ,vsize len)
 731                                     (iincf ,vsize ,tag2))))
 732                              (let ((tag (make-tag $wire-type-string index)))
 733                                `(dolist (,vval ,reader)
 734                                   (let ((len (or (and visited (gethash ,vval visited))
 735                                                  (object-size ,vval ,msg visited))))
 736                                     (iincf ,vsize (length32 ,tag))
 737                                     (iincf ,vsize (length32 len))
 738                                     (iincf ,vsize len)))))))
 739                          ((typep msg 'protobuf-enum)
 740                           (let ((tag (make-tag $wire-type-varint index)))
 741                             (collect-sizer
 742                              `(dolist (,vval ,reader)
 743                                 (iincf ,vsize (enum-size ,vval '(,@(proto-values msg)) ,tag))))))))
 744                   (t
 745                    (cond ((keywordp class)
 746                           (let ((tag (make-tag class index)))
 747                             (collect-sizer
 748                              (if (eq class :bool)
 749                                (if (or (eq (proto-required field) :required)
 750                                        (null (proto-value field)))
 751                                  `(let ((,vval ,reader))
 752                                     (declare (ignorable ,vval))
 753                                     (iincf ,vsize (prim-size ,vval ,class ,tag)))
 754                                  `(let ((,vval (cond ((slot-boundp ,vobj ',(proto-value field))
 755                                                       ,reader)
 756                                                      (t :unbound))))
 757                                     (unless (eq ,vval :unbound)
 758                                       (iincf ,vsize (prim-size ,vval ,class ,tag)))))
 759                                `(let ((,vval ,reader))
 760                                   (when ,vval
 761                                     (iincf ,vsize (prim-size ,vval ,class ,tag))))))))
 762                          ((typep msg 'protobuf-message)
 763                           (collect-sizer
 764                            (if (eq (proto-message-type msg) :group)
 765                              (let ((tag1 (make-tag $wire-type-start-group index))
 766                                    (tag2 (make-tag $wire-type-end-group   index)))
 767                                `(let ((,vval ,reader))
 768                                   (when ,vval
 769                                     (let ((len (or (and visited (gethash ,vval visited))
 770                                                    (object-size ,vval ,msg visited))))
 771                                       (iincf ,vsize (length32 ,tag1))
 772                                       (iincf ,vsize len)
 773                                       (iincf ,vsize (length32 ,tag2))))))
 774                              (let ((tag (make-tag $wire-type-string index)))
 775                                `(let ((,vval ,reader))
 776                                   (when ,vval
 777                                     (let ((len (or (and visited (gethash ,vval visited))
 778                                                    (object-size ,vval ,msg visited))))
 779                                       (iincf ,vsize (length32 ,tag))
 780                                       (iincf ,vsize (length32 len))
 781                                       (iincf ,vsize len))))))))
 782                          ((typep msg 'protobuf-enum)
 783                           (let ((tag (make-tag $wire-type-varint index)))
 784                             (collect-sizer
 785                              `(let ((,vval ,reader))
 786                                 (when ,vval
 787                                   (iincf ,vsize (enum-size ,vval '(,@(proto-values msg)) ,tag)))))))))))))
 788       `(defmethod object-size
 789            (,vobj (,vclass (eql ,message)) &optional visited)
 790            (declare (optimize (speed 3) (safety 0) (debug 0)))
 791          (declare (ignorable visited))
 792          (let ((,vsize (and visited (gethash ,vobj visited))))
 793            (when ,vsize
 794              (return-from object-size ,vsize)))
 795          (let ((,vsize 0))
 796            (declare (type fixnum ,vsize))
 797            ,@sizers
 798            (when visited
 799              (setf (gethash ,vobj visited) ,vsize))
 800            ,vsize)))))