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