1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Free Software published under an MIT-like license. See LICENSE ;;;
5 ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;;
7 ;;; Original author: Scott McKay ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package "PROTO-IMPL")
14 ;;; Protobuf serialization from Lisp objects
18 (defun serialize-object-to-file (filename object type &key visited)
19 "Serializes the object 'object' of type 'type' into the file 'filename'
20 using the wire format.
21 'object' and 'type' are the same as for 'serialize-object-to-bytes'."
22 (with-open-file (stream filename
24 :element-type '(unsigned-byte 8))
25 (serialize-object-to-stream object type :stream stream :visited visited)))
27 (defun serialize-object-to-stream (object type &key (stream *standard-output*) visited)
28 "Serializes the object 'object' of type 'type' onto the stream 'stream'
29 using the wire format.
30 'object' and 'type' are the same as for 'serialize-object-to-bytes'."
31 (let ((buffer (serialize-object-to-bytes object type :visited visited)))
32 (write-sequence buffer stream)
35 (defun serialize-object-to-bytes (object type &key visited)
36 "Serializes the object 'object' of type 'type' into a new byte vector
37 using the wire format.
38 'type' is the Lisp name of a Protobufs message (usually the name of a
39 Lisp class) or a 'protobuf-message'.
40 'visited' is a hash table used to cache object sizes. If it is supplied, it will be
41 cleared before it is used; otherwise, a fresh table will be created.
42 The return value is the buffer containing the serialized object. If the stream is
43 nil, the buffer is not actually written to anywhere."
44 (let* ((visited (let ((v (or visited (make-hash-table))))
47 (size (object-size object type visited))
48 (buffer (make-byte-vector size)))
49 (serialize-object object type buffer 0 visited)
52 ;; Serialize the object using the given protobuf type
55 ;; Allow clients to add their own methods
56 ;; This is how we address the problem of cycles, e.g. -- if you have an object
57 ;; that may contain cycles, serialize the cyclic object using a "handle"
58 (defgeneric serialize-object (object type buffer &optional start visited)
60 "Serializes the object 'object' of type 'type' into the byte array 'buffer'
61 using the wire format.
62 'type' is the Lisp name of a Protobufs message (usually the name of a
63 Lisp class) or a 'protobuf-message'.
64 The object is serialized into the byte array given by 'buffer' starting
65 at the fixnum index 'index' using the wire format.
66 'visited' is a hash table used to cache object sizes.
67 The return value is the buffer containing the serialized object."))
69 (defmethod serialize-object (object type buffer &optional start visited)
70 (let ((message (find-message-for-class type)))
72 "There is no Protobuf message having the type ~S" type)
73 (serialize-object object message buffer start visited)))
75 ;; 'visited' is used to cache object sizes
76 ;; If it's passed in explicitly, it is assumed to already have the sizes within it
77 ;; The default method uses metadata from the protobuf "schema" for the message
78 (defmethod serialize-object (object (message protobuf-message) buffer &optional start visited)
79 (declare (type (simple-array (unsigned-byte 8)) buffer))
80 (let ((visited (or visited (make-hash-table)))
82 (declare (type fixnum index))
83 (macrolet ((read-slot (object slot reader)
84 ;; Don't do a boundp check, we assume the object is fully populated
85 ;; Unpopulated slots should be "nullable" and should contain nil
87 (funcall ,reader ,object)
88 (slot-value ,object ,slot))))
89 (labels ((do-field (object trace field)
90 ;; We don't do cycle detection here
91 ;; If the client needs it, he can define his own 'serialize-object'
92 ;; method to clean things up first
93 (let* ((type (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
94 (slot (proto-value field))
95 (reader (proto-reader field))
97 (when (or slot reader)
98 (cond ((eq (proto-required field) :repeated)
99 (cond ((and (proto-packed field) (packed-type-p type))
100 ;; This is where we handle packed primitive types
101 ;; Packed enums get handled below
102 (let ((tag (make-tag type (proto-index field))))
103 (setq index (serialize-packed (read-slot object slot reader)
104 type tag buffer index))))
106 (let ((tag (make-tag type (proto-index field))))
107 (map () #'(lambda (v)
108 (setq index (serialize-prim v type tag buffer index)))
109 (read-slot object slot reader))))
110 ((typep (setq msg (and type (or (find-message trace type)
111 (find-enum trace type))))
113 (if (eq (proto-message-type msg) :group)
114 (map () #'(lambda (v)
115 ;; To serialize a group, we encode a start tag,
116 ;; serialize the fields, then encode an end tag
117 (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
118 (tag2 (make-tag $wire-type-end-group (proto-index field))))
119 (setq index (encode-uint32 tag1 buffer index))
120 (map () (curry #'do-field v msg)
122 (setq index (encode-uint32 tag2 buffer index))))
123 (if slot (read-slot object slot reader) (list object)))
124 (map () #'(lambda (v)
125 ;; To serialize an embedded message, first say that it's
126 ;; a string, then encode its size, then serialize its fields
127 (let ((tag (make-tag $wire-type-string (proto-index field)))
128 (len (object-size v msg visited)))
129 (setq index (encode-uint32 tag buffer index))
130 (setq index (encode-uint32 len buffer index)))
131 (map () (curry #'do-field v msg)
133 (if slot (read-slot object slot reader) (list object)))))
134 ((typep msg 'protobuf-enum)
135 (let ((tag (make-tag $wire-type-varint (proto-index field))))
136 ;; 'proto-packed-p' of enum types returns nil,
137 ;; so packed enum fields won't be handled above
138 (if (proto-packed field)
139 (setq index (serialize-packed-enum (read-slot object slot reader)
140 (proto-values msg) tag buffer index))
141 (map () #'(lambda (v)
142 (setq index (serialize-enum v (proto-values msg) tag buffer index)))
143 (read-slot object slot reader)))))))
145 (cond ((eq type :bool)
146 ;; We have to handle optional boolean fields specially
147 ;; because "false" and nil are the same value in Lisp
148 (let ((v (cond ((or (eq (proto-required field) :required)
150 (read-slot object slot reader))
151 ((slot-boundp object slot)
152 (read-slot object slot reader))
154 (unless (eq v :unbound)
155 (let ((tag (make-tag :bool (proto-index field))))
156 (setq index (serialize-prim v type tag buffer index))))))
158 (let ((v (read-slot object slot reader)))
160 (let ((tag (make-tag type (proto-index field))))
161 (setq index (serialize-prim v type tag buffer index))))))
162 ((typep (setq msg (and type (or (find-message trace type)
163 (find-enum trace type))))
165 (let ((v (if slot (read-slot object slot reader) object)))
167 (if (eq (proto-message-type msg) :group)
168 (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
169 (tag2 (make-tag $wire-type-end-group (proto-index field))))
170 (setq index (encode-uint32 tag1 buffer index))
171 (map () (curry #'do-field v msg)
173 (setq index (encode-uint32 tag2 buffer index)))
174 (let ((tag (make-tag $wire-type-string (proto-index field)))
175 (len (object-size v msg visited)))
176 (setq index (encode-uint32 tag buffer index))
177 (setq index (encode-uint32 len buffer index))
178 (map () (curry #'do-field v msg)
179 (proto-fields msg)))))))
180 ((typep msg 'protobuf-enum)
181 (let ((v (read-slot object slot reader)))
183 (let ((tag (make-tag $wire-type-varint (proto-index field))))
184 (setq index (serialize-enum v (proto-values msg) tag buffer index)))))))))))))
185 (declare (dynamic-extent #'do-field))
186 (map () (curry #'do-field object message) (proto-fields message))))
187 (values buffer index)))
192 (defun deserialize-object-from-file (type filename)
193 "Deserializes an object of the given type 'type' from the given file
194 as a Protobuf object."
195 (with-open-file (stream filename
197 :element-type '(unsigned-byte 8))
198 (deserialize-object-from-stream type :stream stream)))
200 (defun deserialize-object-from-stream (type &key (stream *standard-input*))
201 "Deserializes an object of the given type 'type' from the given stream
202 as a Protobuf object."
203 (let* ((size (file-length stream))
204 (buffer (make-byte-vector size)))
205 (read-sequence buffer stream)
206 (deserialize-object type buffer 0 size)))
208 (defun deserialize-object-from-bytes (type buffer)
209 "Deserializes an object of the given type 'type' from the given stream
210 as a Protobuf object.
211 'type' is the Lisp name of a Protobufs message (usually the name of a
212 Lisp class) or a 'protobuf-message'.
213 The return value is the object."
214 (deserialize-object type buffer))
216 ;; Allow clients to add their own methods
217 ;; This is you might preserve object identity, e.g.
218 (defgeneric deserialize-object (type buffer &optional start end end-tag)
220 "Deserializes an object of the given type 'type' as a Protobufs object.
221 'type' is the Lisp name of a Protobufs message (usually the name of a
222 Lisp class) or a 'protobuf-message'.
223 The encoded bytes are in the byte array given by 'buffer' starting at
224 the fixnum index 'start' up to the end of the buffer, given by 'end'.
225 'start' defaults to 0, 'end' defaults to the length of the buffer.
226 'end-tag' is used internally to handle the (deprecated) \"group\" feature.
227 The return values are the object and the index at which deserialization stopped.."))
229 (defmethod deserialize-object (type buffer &optional start end (end-tag 0))
230 (let ((message (find-message-for-class type)))
232 "There is no Protobuf message having the type ~S" type)
233 (deserialize-object message buffer start end end-tag)))
235 ;; The default method uses metadata from the protobuf "schema" for the message
236 (defmethod deserialize-object ((message protobuf-message) buffer &optional start end (end-tag 0))
237 (declare (type (simple-array (unsigned-byte 8)) buffer))
238 (let ((index (or start 0))
239 (length (or end (length buffer))))
240 (declare (type fixnum index length))
241 (macrolet ((read-slot (object slot reader)
243 (funcall ,reader ,object)
244 (slot-value ,object ,slot)))
245 (write-slot (object slot writer value)
247 `(let ((,vval ,value))
249 (funcall ,writer ,object ,vval)
250 (setf (slot-value ,object ,slot) ,vval))))))
251 (labels ((deserialize (type trace end end-tag)
252 (declare (type fixnum end end-tag))
253 (let* ((message (find-message trace type))
255 (make-instance (or (proto-alias-for message) (proto-class message)))))
256 ;; All the slots into which we store a repeated element
257 ;; These will be reversed at the end of deserialization
260 (multiple-value-bind (tag idx)
261 (if (i< index end) (decode-uint32 buffer index) (values 0 index))
262 ;; We're done if we've gotten to the end index or
263 ;; we see an end tag that matches a previous group's start tag
264 ;; Note that the default end tag is 0, which is also an end of
265 ;; message marker (there can never be "real" zero tags because
266 ;; field indices start at 1)
268 (when (i= tag end-tag)
269 ;; Reverse the repeated slots
270 (dolist (field rslots)
271 (let ((slot (proto-value field))
272 (reader (proto-reader field))
273 (writer (proto-writer field)))
274 (write-slot object slot writer
275 (nreverse (read-slot object slot reader)))))
276 (return-from deserialize
277 (values object index)))
278 (let* ((fidx (ilogand (iash tag -3) #x1FFFFFFF))
279 (field (find fidx (proto-fields message) :key #'proto-index))
280 (type (and field (if (eq (proto-class field) 'boolean) :bool (proto-class field))))
281 ;; It's OK for this to be null
282 ;; That means we're parsing some version of a message
283 ;; that has the field, but our current message does not
284 ;; We still have to deserialize everything, though
285 (slot (and field (proto-value field)))
286 (reader (and field (proto-reader field)))
287 (writer (and field (proto-writer field)))
290 ;; If there's no field descriptor for this index, just skip
291 ;; the next element in the buffer having the given wire type
292 (setq index (skip-element buffer index tag))
293 ;;--- Check for mismatched wire type, running past end of buffer, etc
294 (cond ((and field (eq (proto-required field) :repeated))
295 (let ((vectorp (vector-field-p field)))
296 (cond ((and (proto-packed field) (packed-type-p type))
297 (multiple-value-bind (values idx)
298 (deserialize-packed type buffer index)
301 (let ((values (make-array (length values)
302 :fill-pointer t :adjustable t
303 :initial-contents values)))
304 (write-slot object slot writer values))
305 (write-slot object slot writer values))))
307 (multiple-value-bind (val idx)
308 (deserialize-prim type buffer index)
311 (vector-push-extend val (read-slot object slot reader)))
313 (pushnew field rslots)
314 ;; This "push" could type-check the entire list if
315 ;; there's a parameterized list type in effect,
316 ;; so you'll want to avoid using such types
317 ;; We'll reverse the slots at the last minute
318 (write-slot object slot writer
319 (cons val (read-slot object slot reader)))))))
320 ((typep (setq msg (and type (or (find-message trace type)
321 (find-enum trace type))))
323 (if (eq (proto-message-type msg) :group)
324 (let* ((etag (make-tag $wire-type-end-group fidx))
325 (obj (deserialize type msg length etag)))
327 (vector-push-extend obj (read-slot object slot reader)))
329 (pushnew field rslots)
330 (write-slot object slot writer
331 (cons obj (read-slot object slot reader))))))
332 (multiple-value-bind (len idx)
333 (decode-uint32 buffer index)
335 (let ((obj (deserialize type msg (+ index len) 0)))
337 (vector-push-extend obj (read-slot object slot reader)))
339 (pushnew field rslots)
340 (write-slot object slot writer
341 (cons obj (read-slot object slot reader)))))))))
342 ((typep msg 'protobuf-enum)
343 (if (proto-packed field)
344 (multiple-value-bind (values idx)
345 (deserialize-packed-enum (proto-values msg) buffer index)
348 (let ((values (make-array (length values)
349 :fill-pointer t :adjustable t
350 :initial-contents values)))
351 (write-slot object slot writer values))
352 (write-slot object slot writer values)))
353 (multiple-value-bind (val idx)
354 (deserialize-enum (proto-values msg) buffer index)
357 (vector-push-extend val (read-slot object slot reader)))
359 (pushnew field rslots)
360 (write-slot object slot writer
361 (cons val (read-slot object slot reader)))))))))))
363 (cond ((keywordp type)
364 (multiple-value-bind (val idx)
365 (deserialize-prim type buffer index)
367 (write-slot object slot writer val)))
368 ((typep (setq msg (and type (or (find-message trace type)
369 (find-enum trace type))))
371 ;;--- If there's already a value in the slot, merge messages
372 (if (eq (proto-message-type msg) :group)
373 (let* ((etag (make-tag $wire-type-end-group fidx))
374 (obj (deserialize type msg length etag)))
375 (write-slot object slot writer obj))
376 (multiple-value-bind (len idx)
377 (decode-uint32 buffer index)
379 (let ((obj (deserialize type msg (+ index len) 0)))
380 (write-slot object slot writer obj)))))
381 ((typep msg 'protobuf-enum)
382 (multiple-value-bind (val idx)
383 (deserialize-enum (proto-values msg) buffer index)
385 (write-slot object slot writer val)))))))))))))
386 (declare (dynamic-extent #'deserialize))
387 (deserialize (proto-class message) message length end-tag)))))
391 ;; Allow clients to add their own methods
392 ;; This is how we address the problem of cycles, e.g. -- if you have an object
393 ;; that may contain cycles, return the size of the "handle" to the object
394 (defgeneric object-size (object type &optional visited)
396 "Computes the size in bytes of the object 'object' of type 'type'.
397 'type' is the Lisp name of a Protobufs message (usually the name of a
398 Lisp class) or a 'protobuf-message'.
399 'visited' is a hash table used to cache object sizes.
400 The return value is the size of the object in bytes."))
402 (defmethod object-size (object type &optional visited)
403 (let ((message (find-message-for-class type)))
405 "There is no Protobuf message having the type ~S" type)
406 (object-size object message visited)))
408 ;; 'visited' is used to cache object sizes
409 ;; The default method uses metadata from the protobuf "schema" for the message
410 (defmethod object-size (object (message protobuf-message) &optional visited)
411 (let ((size (and visited (gethash object visited))))
413 (return-from object-size size)))
415 (declare (type fixnum size))
416 (macrolet ((read-slot (object slot reader)
417 ;; Don't do a boundp check, we assume the object is fully populated
418 ;; Unpopulated slots should be "nullable" and should contain nil
420 (funcall ,reader ,object)
421 (slot-value ,object ,slot))))
422 (labels ((do-field (object trace field)
423 ;; We don't do cycle detection here
424 ;; If the client needs it, he can define his own 'object-size'
425 ;; method to clean things up first
426 (let* ((type (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
427 (slot (proto-value field))
428 (reader (proto-reader field))
430 (when (or slot reader)
431 (cond ((eq (proto-required field) :repeated)
432 (cond ((and (proto-packed field) (packed-type-p type))
433 (let ((tag (make-tag type (proto-index field))))
434 (iincf size (packed-size (read-slot object slot reader) type tag))))
436 (let ((tag (make-tag type (proto-index field))))
437 (map () #'(lambda (v)
438 (iincf size (prim-size v type tag)))
439 (read-slot object slot reader))))
440 ((typep (setq msg (and type (or (find-message trace type)
441 (find-enum trace type))))
443 (if (eq (proto-message-type msg) :group)
444 (map () #'(lambda (v)
445 (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
446 (tag2 (make-tag $wire-type-end-group (proto-index field))))
447 (iincf size (length32 tag1))
448 (map () (curry #'do-field v msg)
450 (iincf size (length32 tag2))))
451 (if slot (read-slot object slot reader) (list object)))
452 (map () #'(lambda (v)
453 (let ((tag (make-tag $wire-type-string (proto-index field)))
454 (len (object-size v msg visited)))
455 (iincf size (length32 tag))
456 (iincf size (length32 len))
457 (map () (curry #'do-field v msg)
458 (proto-fields msg))))
459 (if slot (read-slot object slot reader) (list object)))))
460 ((typep msg 'protobuf-enum)
461 (let ((tag (make-tag $wire-type-varint (proto-index field))))
462 (if (proto-packed field)
463 (iincf size (packed-enum-size (read-slot object slot reader) type tag))
464 (map () #'(lambda (v)
465 (iincf size (enum-size v (proto-values msg) tag)))
466 (read-slot object slot reader)))))))
468 (cond ((eq type :bool)
469 (let ((v (cond ((or (eq (proto-required field) :required)
471 (read-slot object slot reader))
472 ((slot-boundp object slot)
473 (read-slot object slot reader))
475 (unless (eq v :unbound)
476 (let ((tag (make-tag :bool (proto-index field))))
477 (iincf size (prim-size v type tag))))))
479 (let ((v (read-slot object slot reader)))
481 (let ((tag (make-tag type (proto-index field))))
482 (iincf size (prim-size v type tag))))))
483 ((typep (setq msg (and type (or (find-message trace type)
484 (find-enum trace type))))
486 (let ((v (if slot (read-slot object slot reader) object)))
488 (if (eq (proto-message-type msg) :group)
489 (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
490 (tag2 (make-tag $wire-type-end-group (proto-index field))))
491 (iincf size (length32 tag1))
492 (map () (curry #'do-field v msg)
494 (iincf size (length32 tag2)))
495 (let ((tag (make-tag $wire-type-string (proto-index field)))
496 (len (object-size v msg visited)))
497 (iincf size (length32 tag))
498 (iincf size (length32 len))
499 (map () (curry #'do-field v msg)
500 (proto-fields msg)))))))
501 ((typep msg 'protobuf-enum)
502 (let ((v (read-slot object slot reader)))
504 (let ((tag (make-tag $wire-type-varint (proto-index field))))
505 (iincf size (enum-size (read-slot object slot reader) (proto-values msg) tag)))))))))))))
506 (declare (dynamic-extent #'do-field))
507 (map () (curry #'do-field object message) (proto-fields message))
509 (setf (gethash object visited) size)) ;cache the size
513 ;;; Compile-time generation of serializers
514 ;;; Type-checking is done at the top-level methods specialized on 'symbol',
515 ;;; so we turn off all type checking at the level of these functions
517 ;; Note well: keep this in sync with the main 'serialize-object' method above
518 (defun generate-serializer (message)
519 "Generate a 'serialize-object' method for the given message."
520 (with-gensyms (vobj vbuf vidx vval vclass)
521 (when (null (proto-fields message))
522 (return-from generate-serializer
523 `(defmethod serialize-object
524 (,vobj (,vclass (eql ,message)) ,vbuf &optional (,vidx 0) visited)
525 (declare #.$optimize-serialization)
526 (declare (ignorable ,vobj ,vclass visited)
527 (type (simple-array (unsigned-byte 8)) ,vbuf)
529 (values ,vbuf ,vidx))))
530 (with-collectors ((serializers collect-serializer))
531 (dolist (field (proto-fields message))
532 (let* ((class (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
533 (msg (and class (not (keywordp class))
534 (or (find-message message class)
535 (find-enum message class))))
536 (reader (cond ((proto-reader field)
537 `(,(proto-reader field) ,vobj))
539 `(slot-value ,vobj ',(proto-value field)))))
540 (index (proto-index field)))
542 (cond ((eq (proto-required field) :repeated)
543 (let ((iterator (if (vector-field-p field) 'dovector 'dolist)))
544 (cond ((and (proto-packed field) (packed-type-p class))
546 (let ((tag (make-tag class index)))
547 `(setq ,vidx (serialize-packed ,reader ,class ,tag ,vbuf ,vidx)))))
550 (let ((tag (make-tag class index)))
551 `(,iterator (,vval ,reader)
552 (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))))
553 ((typep msg 'protobuf-message)
555 (if (eq (proto-message-type msg) :group)
556 (let ((tag1 (make-tag $wire-type-start-group index))
557 (tag2 (make-tag $wire-type-end-group index)))
558 `(,iterator (,vval ,reader)
559 (let ((len (or (and visited (gethash ,vval visited))
560 (object-size ,vval ,msg visited))))
561 (setq ,vidx (encode-uint32 ,tag1 ,vbuf ,vidx))
562 (serialize-object ,vval ,msg ,vbuf ,vidx visited)
564 (setq ,vidx (encode-uint32 ,tag2 ,vbuf ,vidx)))))
565 (let ((tag (make-tag $wire-type-string index)))
566 `(,iterator (,vval ,reader)
567 (let ((len (or (and visited (gethash ,vval visited))
568 (object-size ,vval ,msg visited))))
569 (setq ,vidx (encode-uint32 ,tag ,vbuf ,vidx))
570 (setq ,vidx (encode-uint32 len ,vbuf ,vidx))
571 (serialize-object ,vval ,msg ,vbuf ,vidx visited)
572 (iincf ,vidx len)))))))
573 ((typep msg 'protobuf-enum)
575 (let ((tag (make-tag $wire-type-varint index)))
576 (if (proto-packed field)
577 `(setq ,vidx (serialize-packed-enum ,reader '(,@(proto-values msg)) ,tag ,vbuf ,vidx))
579 `(,iterator (,vval ,reader)
580 (setq ,vidx (serialize-enum ,vval '(,@(proto-values msg)) ,tag ,vbuf ,vidx))))))))))
582 (cond ((keywordp class)
584 (let ((tag (make-tag class index)))
586 (if (or (eq (proto-required field) :required)
588 `(let ((,vval ,reader))
589 (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx)))
590 `(let ((,vval (cond ((slot-boundp ,vobj ',(proto-value field))
593 (unless (eq ,vval :unbound)
594 (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx)))))
595 `(let ((,vval ,reader))
597 (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))))))
598 ((typep msg 'protobuf-message)
600 (if (eq (proto-message-type msg) :group)
601 (let ((tag1 (make-tag $wire-type-start-group index))
602 (tag2 (make-tag $wire-type-end-group index)))
603 `(let ((,vval ,reader))
605 (let ((len (or (and visited (gethash ,vval visited))
606 (object-size ,vval ,msg visited))))
607 (setq ,vidx (encode-uint32 ,tag1 ,vbuf ,vidx))
608 (serialize-object ,vval ,msg ,vbuf ,vidx visited)
610 (setq ,vidx (encode-uint32 ,tag2 ,vbuf ,vidx))))))
611 (let ((tag (make-tag $wire-type-string index)))
612 `(let ((,vval ,reader))
614 (let ((len (or (and visited (gethash ,vval visited))
615 (object-size ,vval ,msg visited))))
616 (setq ,vidx (encode-uint32 ,tag ,vbuf ,vidx))
617 (setq ,vidx (encode-uint32 len ,vbuf ,vidx))
618 (serialize-object ,vval ,msg ,vbuf ,vidx visited)
619 (iincf ,vidx len))))))))
620 ((typep msg 'protobuf-enum)
622 (let ((tag (make-tag $wire-type-varint index)))
623 `(let ((,vval ,reader))
625 (setq ,vidx (serialize-enum ,vval '(,@(proto-values msg)) ,tag ,vbuf ,vidx)))))))))))))
626 `(defmethod serialize-object
627 (,vobj (,vclass (eql ,message)) ,vbuf &optional (,vidx 0) visited)
628 (declare #.$optimize-serialization)
629 (declare (ignorable visited)
630 (type (simple-array (unsigned-byte 8)) ,vbuf)
633 (values ,vbuf ,vidx)))))
635 ;; Note well: keep this in sync with the main 'deserialize-object' method above
636 (defun generate-deserializer (message)
637 "Generate a 'deserialize-object' method for the given message."
638 (with-gensyms (vclass vbuf vidx vlen vendtag vobj vval)
639 (when (null (proto-fields message))
640 (return-from generate-deserializer
641 `(defmethod deserialize-object
642 ((,vclass (eql ,message)) ,vbuf &optional ,vidx ,vlen (,vendtag 0))
643 (declare #.$optimize-serialization)
644 (declare (ignorable ,vclass ,vbuf ,vlen ,vendtag)
645 (type (simple-array (unsigned-byte 8)) ,vbuf))
646 (let ((,vidx (or ,vidx 0)))
647 (declare (type fixnum ,vidx))
648 (let ((,vobj (make-instance ',(or (proto-alias-for message) (proto-class message)))))
649 (values ,vobj ,vidx))))))
650 (with-collectors ((deserializers collect-deserializer)
651 ;; For tracking repeated slots that will need to be reversed
652 (rslots collect-rslot))
653 (flet ((read-slot (object field)
654 (cond ((proto-reader field)
655 `(,(proto-reader field) ,object))
657 `(slot-value ,object ',(proto-value field)))))
658 (write-slot (object field value)
659 (cond ((proto-writer field)
660 `(,(proto-writer field) ,object ,value))
662 `(setf (slot-value ,object ',(proto-value field)) ,value)))))
663 (dolist (field (proto-fields message))
664 (let* ((class (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
665 (msg (and class (not (keywordp class))
666 (or (find-message message class)
667 (find-enum message class))))
668 (index (proto-index field)))
669 (cond ((eq (proto-required field) :repeated)
670 (cond ((and (proto-packed field) (packed-type-p class))
671 (collect-deserializer
672 `((,(make-tag class index))
673 (multiple-value-bind (,vval idx)
674 (deserialize-packed ,class ,vbuf ,vidx)
676 ,@(when (vector-field-p field)
677 `((setq ,vval (make-array (length ,vval)
678 :fill-pointer t :adjustable t
679 :initial-contents ,vval))))
680 ,(write-slot vobj field vval)))))
682 (let ((temp (gensym (string (proto-value field)))))
683 (collect-rslot (list field temp))
684 (collect-deserializer
685 `((,(make-tag class index))
686 (multiple-value-bind (,vval idx)
687 (deserialize-prim ,class ,vbuf ,vidx)
689 (push ,vval ,temp))))))
690 ((typep msg 'protobuf-message)
691 (let ((temp (gensym (string (proto-value field)))))
692 (collect-rslot (list field temp))
693 (collect-deserializer
694 (if (eq (proto-message-type msg) :group)
695 `((,(make-tag $wire-type-start-group index))
696 (multiple-value-bind (,vval idx)
697 (deserialize-object ,msg ,vbuf ,vidx ,vlen
698 ,(make-tag $wire-type-end-group index))
701 `((,(make-tag $wire-type-string index))
702 (multiple-value-bind (len idx)
703 (decode-uint32 ,vbuf ,vidx)
705 (multiple-value-bind (,vval idx)
706 (deserialize-object ,msg ,vbuf ,vidx (i+ ,vidx len) 0)
708 (push ,vval ,temp))))))))
709 ((typep msg 'protobuf-enum)
710 (if (proto-packed field)
711 (collect-deserializer
712 `((,(make-tag $wire-type-varint index))
713 (multiple-value-bind (,vval idx)
714 (deserialize-packed-enum '(,@(proto-values msg)) ,vbuf ,vidx)
716 ,(write-slot vobj field vval))))
717 (let ((temp (gensym (string (proto-value field)))))
718 (collect-rslot (list field temp))
719 (collect-deserializer
720 `((,(make-tag $wire-type-varint index))
721 (multiple-value-bind (,vval idx)
722 (deserialize-enum '(,@(proto-values msg)) ,vbuf ,vidx)
724 (push ,vval ,temp)))))))))
726 (cond ((keywordp class)
727 (collect-deserializer
728 `((,(make-tag class index))
729 (multiple-value-bind (,vval idx)
730 (deserialize-prim ,class ,vbuf ,vidx)
732 ,(write-slot vobj field vval)))))
733 ((typep msg 'protobuf-message)
734 (collect-deserializer
735 (if (eq (proto-message-type msg) :group)
736 `((,(make-tag $wire-type-start-group index))
737 (multiple-value-bind (,vval idx)
738 (deserialize-object ,msg ,vbuf ,vidx ,vlen
739 ,(make-tag $wire-type-end-group index))
741 ,(write-slot vobj field vval)))
742 `((,(make-tag $wire-type-string index))
743 (multiple-value-bind (len idx)
744 (decode-uint32 ,vbuf ,vidx)
746 (multiple-value-bind (,vval idx)
747 (deserialize-object ,msg ,vbuf ,vidx (i+ ,vidx len) 0)
749 ,(write-slot vobj field vval)))))))
750 ((typep msg 'protobuf-enum)
751 (collect-deserializer
752 `((,(make-tag $wire-type-varint index))
753 (multiple-value-bind (,vval idx)
754 (deserialize-enum '(,@(proto-values msg)) ,vbuf ,vidx)
756 ,(write-slot vobj field vval)))))))))))
757 (let* ((rslots (delete-duplicates rslots :key #'first))
758 (rfields (mapcar #'first rslots))
759 (rtemps (mapcar #'second rslots)))
760 `(defmethod deserialize-object
761 ((,vclass (eql ,message)) ,vbuf &optional ,vidx ,vlen (,vendtag 0))
762 (declare #.$optimize-serialization)
763 (declare (type (simple-array (unsigned-byte 8)) ,vbuf))
764 (let ((,vidx (or ,vidx 0))
765 (,vlen (or ,vlen (length ,vbuf))))
766 (declare (type fixnum ,vidx ,vlen))
767 (let ((,vobj (make-instance ',(or (proto-alias-for message) (proto-class message))))
768 ;; Bind the temporary variables that hold repeated slots
771 (multiple-value-bind (tag idx)
772 (if (i< ,vidx ,vlen) (decode-uint32 ,vbuf ,vidx) (values 0 ,vidx))
774 (when (i= tag ,vendtag)
775 ;; Set the (un)reversed values of the repeated slots
776 ,@(loop for field in rfields
778 as slot = (proto-value field)
779 as writer = (proto-writer field)
780 collect (cond ((vector-field-p field)
782 `(funcall ,writer ,vobj (make-array (length ,temp)
783 :fill-pointer t :adjustable t
784 :initial-contents (nreverse ,temp)))
785 `(setf (slot-value ,vobj ',slot) (make-array (length ,temp)
786 :fill-pointer t :adjustable t
787 :initial-contents (nreverse ,temp)))))
790 `(funcall ,writer ,vobj (nreverse ,temp))
791 `(setf (slot-value ,vobj ',slot) (nreverse ,temp))))))
792 (return-from deserialize-object
793 (values ,vobj ,vidx)))
797 (setq ,vidx (skip-element ,vbuf ,vidx tag)))))))))))))
799 ;; Note well: keep this in sync with the main 'object-size' method above
800 (defun generate-object-size (message)
801 "Generate an 'object-size' method for the given message."
802 (with-gensyms (vobj vsize vval vclass)
803 (when (null (proto-fields message))
804 (return-from generate-object-size
805 `(defmethod object-size
806 (,vobj (,vclass (eql ,message)) &optional visited)
807 (declare #.$optimize-serialization)
808 (declare (ignorable ,vobj visited))
810 (with-collectors ((sizers collect-sizer))
811 (dolist (field (proto-fields message))
812 (let* ((class (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
813 (msg (and class (not (keywordp class))
814 (or (find-message message class)
815 (find-enum message class))))
816 (reader (cond ((proto-reader field)
817 `(,(proto-reader field) ,vobj))
819 `(slot-value ,vobj ',(proto-value field)))))
820 (index (proto-index field)))
822 (cond ((eq (proto-required field) :repeated)
823 (let ((iterator (if (vector-field-p field) 'dovector 'dolist)))
824 (cond ((and (proto-packed field) (packed-type-p class))
826 (let ((tag (make-tag class index)))
827 `(iincf ,vsize (packed-size ,reader ,class ,tag)))))
830 (let ((tag (make-tag class index)))
831 `(,iterator (,vval ,reader)
832 (iincf ,vsize (prim-size ,vval ,class ,tag))))))
833 ((typep msg 'protobuf-message)
835 (if (eq (proto-message-type msg) :group)
836 (let ((tag1 (make-tag $wire-type-start-group index))
837 (tag2 (make-tag $wire-type-end-group index)))
838 `(,iterator (,vval ,reader)
839 (let ((len (or (and visited (gethash ,vval visited))
840 (object-size ,vval ,msg visited))))
841 (iincf ,vsize (length32 ,tag1))
843 (iincf ,vsize ,tag2))))
844 (let ((tag (make-tag $wire-type-string index)))
845 `(,iterator (,vval ,reader)
846 (let ((len (or (and visited (gethash ,vval visited))
847 (object-size ,vval ,msg visited))))
848 (iincf ,vsize (length32 ,tag))
849 (iincf ,vsize (length32 len))
850 (iincf ,vsize len)))))))
851 ((typep msg 'protobuf-enum)
852 (let ((tag (make-tag $wire-type-varint index)))
854 (if (proto-packed field)
855 `(iincf ,vsize (packed-enum-size ,reader '(,@(proto-values msg)) ,tag))
856 `(,iterator (,vval ,reader)
857 (iincf ,vsize (enum-size ,vval '(,@(proto-values msg)) ,tag))))))))))
859 (cond ((keywordp class)
860 (let ((tag (make-tag class index)))
863 (if (or (eq (proto-required field) :required)
865 `(let ((,vval ,reader))
866 (declare (ignorable ,vval))
867 (iincf ,vsize (prim-size ,vval ,class ,tag)))
868 `(let ((,vval (cond ((slot-boundp ,vobj ',(proto-value field))
871 (unless (eq ,vval :unbound)
872 (iincf ,vsize (prim-size ,vval ,class ,tag)))))
873 `(let ((,vval ,reader))
875 (iincf ,vsize (prim-size ,vval ,class ,tag))))))))
876 ((typep msg 'protobuf-message)
878 (if (eq (proto-message-type msg) :group)
879 (let ((tag1 (make-tag $wire-type-start-group index))
880 (tag2 (make-tag $wire-type-end-group index)))
881 `(let ((,vval ,reader))
883 (let ((len (or (and visited (gethash ,vval visited))
884 (object-size ,vval ,msg visited))))
885 (iincf ,vsize (length32 ,tag1))
887 (iincf ,vsize (length32 ,tag2))))))
888 (let ((tag (make-tag $wire-type-string index)))
889 `(let ((,vval ,reader))
891 (let ((len (or (and visited (gethash ,vval visited))
892 (object-size ,vval ,msg visited))))
893 (iincf ,vsize (length32 ,tag))
894 (iincf ,vsize (length32 len))
895 (iincf ,vsize len))))))))
896 ((typep msg 'protobuf-enum)
897 (let ((tag (make-tag $wire-type-varint index)))
899 `(let ((,vval ,reader))
901 (iincf ,vsize (enum-size ,vval '(,@(proto-values msg)) ,tag)))))))))))))
902 `(defmethod object-size
903 (,vobj (,vclass (eql ,message)) &optional visited)
904 (declare #.$optimize-serialization)
905 (declare (ignorable visited))
906 (let ((,vsize (and visited (gethash ,vobj visited))))
908 (return-from object-size ,vsize)))
910 (declare (type fixnum ,vsize))
913 (setf (gethash ,vobj visited) ,vsize))