1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Free Software published under an MIT-like license. See LICENSE ;;;
5 ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;;
7 ;;; Original author: Scott McKay ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package "PROTO-IMPL")
14 ;;; Protobuf serialization from Lisp objects
18 (defgeneric make-size-cache (object type)
20 "Make an object size cache for 'object'."))
22 ;; Note that this gets called on the top-level object being serialized
23 ;; This means that either all the objects in the tree should be subclasses
24 ;; of 'base-protobuf-message', or none of them should be. If the root is
25 ;; not a 'base-protobuf-message', then things will work but be slower; if
26 ;; the root is a 'base-protobuf-message', but some children are not, then
27 ;; serialization will fail.
28 (defmethod make-size-cache ((object standard-object) type)
29 (declare (ignore type))
30 ;; No '%cached-size' slot in standard objects, create a "visited" table
33 (defmethod make-size-cache ((object base-protobuf-message) type)
34 ;; In classes defined by Protobufs, we will use the '%cached-size' slot
35 ;; This clears the size cache for the tree of objects
36 (clear-size-cache object type)
40 (declaim (inline cached-object-size))
41 (defun cached-object-size (object visited)
42 (declare #.$optimize-fast-unsafe)
44 (gethash object visited)
45 ;; Warning, Will Robinson! Danger!
46 ;; If there's no 'visited' table, assume there's a cached size slot.
47 ;; We should use methods speciaized on 'base-protobuf-message',
48 ;; but we're trying to max out the speed.
49 (slot-value object '%cached-size)))
51 (defun (setf cached-object-size) (size object visited)
52 (declare #.$optimize-fast-unsafe)
54 (setf (gethash object visited) size)
55 (setf (slot-value object '%cached-size) size)))
58 (defgeneric clear-size-cache (object type)
60 "Clear the size cache for a tree of objects."))
62 (defmethod clear-size-cache ((object standard-object) type)
63 (declare (ignore type))
66 (defmethod clear-size-cache ((object base-protobuf-message) type)
67 (let ((message (find-message-for-class type)))
69 (serialization-error "There is no Protobuf message having the type ~S" type))
70 (macrolet ((read-slot (object slot reader)
72 (funcall ,reader ,object)
73 (slot-value ,object ,slot))))
74 (labels ((do-field (object trace field)
75 (let* ((type (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
76 (slot (proto-value field))
77 (reader (proto-reader field))
79 (when (or slot reader)
80 (cond ((eq (proto-required field) :repeated)
81 (cond ((or (and (proto-packed field) (packed-type-p type))
83 ((typep (setq msg (and type (find-message trace type))) 'protobuf-message)
84 (setf (slot-value object '%cached-size) nil)
85 (doseq (v (if slot (read-slot object slot reader) (list object)))
86 (dolist (f (proto-fields msg))
87 (do-field v msg f))))))
89 (cond ((keywordp type))
90 ((typep (setq msg (and type (find-message trace type))) 'protobuf-message)
91 (setf (slot-value object '%cached-size) nil)
92 (let ((v (if slot (read-slot object slot reader) object)))
94 (dolist (f (proto-fields msg))
95 (do-field v msg f))))))))))))
96 (declare (dynamic-extent #'do-field))
97 (setf (slot-value object '%cached-size) nil)
98 (dolist (field (proto-fields message))
99 (do-field object message field))
105 (defun serialize-object-to-file (filename object type &key visited)
106 "Serializes the object 'object' of type 'type' into the file 'filename'
107 using the wire format.
108 'object' and 'type' are the same as for 'serialize-object-to-bytes'."
109 (with-open-file (stream filename
111 :element-type '(unsigned-byte 8))
112 (serialize-object-to-stream object type :stream stream :visited visited)))
114 (defun serialize-object-to-stream (object type &key (stream *standard-output*) visited)
115 "Serializes the object 'object' of type 'type' onto the stream 'stream'
116 using the wire format.
117 'object' and 'type' are the same as for 'serialize-object-to-bytes'."
118 (let ((buffer (serialize-object-to-bytes object type :visited visited)))
119 (write-sequence buffer stream)
122 (defun serialize-object-to-bytes (object type &key visited)
123 "Serializes the object 'object' of type 'type' into a new byte vector
124 using the wire format.
125 'type' is the Lisp name of a Protobufs message (usually the name of a
126 Lisp class) or a 'protobuf-message'.
127 'visited' is a hash table used to cache object sizes. If it is supplied, it will be
128 cleared before it is used; otherwise, a fresh table will be created if necessary.
129 The return value is the buffer containing the serialized object. If the stream is
130 nil, the buffer is not actually written to anywhere."
131 (let* ((visited (let ((v (or visited (make-size-cache object type))))
134 ;; Use 'object-size' to forcibly recompute all the sizes
135 (size (object-size object type visited))
136 (buffer (make-byte-vector size)))
137 (serialize-object object type buffer 0 visited)
140 ;; Serialize the object using the given protobuf type
143 ;; Allow clients to add their own methods
144 ;; This is how we address the problem of cycles, e.g. -- if you have an object
145 ;; that may contain cycles, serialize the cyclic object using a "handle"
146 (defgeneric serialize-object (object type buffer &optional start visited)
148 "Serializes the object 'object' of type 'type' into the byte array 'buffer'
149 using the wire format.
150 'type' is the Lisp name of a Protobufs message (usually the name of a
151 Lisp class) or a 'protobuf-message'.
152 The object is serialized into the byte array given by 'buffer' starting
153 at the fixnum index 'index' using the wire format.
154 'visited' is a hash table used to cache object sizes; if this is nil, then
155 the object caches its size itself in a '%cached-size' slot.
156 The return value is the buffer containing the serialized object."))
158 (defmethod serialize-object (object type buffer &optional start visited)
159 (let ((message (find-message-for-class type)))
161 (serialization-error "There is no Protobuf message having the type ~S" type))
163 (serialize-object object message buffer start visited)
165 (serialization-error "Error serializing object ~S: ~A" object (princ-to-string e))))))
167 ;; 'visited' is used to cache object sizes
168 ;; If it's non-nil. it must to be a table with the sizes already in it
169 ;; If it's nil, then the objects must have a '%cached-size' slot
170 ;; The default method uses metadata from the protobuf "schema" for the message
171 (defmethod serialize-object (object (message protobuf-message) buffer &optional start visited)
172 (declare (type (simple-array (unsigned-byte 8)) buffer))
173 (let ((index (or start 0)))
174 (declare (type fixnum index))
175 (macrolet ((read-slot (object slot reader)
176 ;; Don't do a boundp check, we assume the object is fully populated
177 ;; Unpopulated slots should be "nullable" and will contain nil when empty
179 (funcall ,reader ,object)
180 (slot-value ,object ,slot))))
181 (labels ((do-field (object trace field)
182 ;; We don't do cycle detection here
183 ;; If the client needs it, he can define his own 'serialize-object'
184 ;; method to clean things up first
185 (let* ((type (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
186 (slot (proto-value field))
187 (reader (proto-reader field))
189 (when (or slot reader)
190 (cond ((eq (proto-required field) :repeated)
191 (cond ((and (proto-packed field) (packed-type-p type))
192 ;; This is where we handle packed primitive types
193 ;; Packed enums get handled below
194 (let ((tag (make-tag type (proto-index field))))
195 (setq index (serialize-packed (read-slot object slot reader)
196 type tag buffer index))))
198 (let ((tag (make-tag type (proto-index field))))
199 (doseq (v (read-slot object slot reader))
200 (setq index (serialize-prim v type tag buffer index)))))
201 ((typep (setq msg (and type (or (find-message trace type)
202 (find-enum trace type)
203 (find-type-alias trace type))))
205 (if (eq (proto-message-type msg) :group)
206 (doseq (v (if slot (read-slot object slot reader) (list object)))
207 ;; To serialize a group, we encode a start tag,
208 ;; serialize the fields, then encode an end tag
209 (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
210 (tag2 (make-tag $wire-type-end-group (proto-index field))))
211 (setq index (encode-uint32 tag1 buffer index))
212 (dolist (f (proto-fields msg))
214 (setq index (encode-uint32 tag2 buffer index))))
215 (doseq (v (if slot (read-slot object slot reader) (list object)))
216 ;; To serialize an embedded message, first say that it's
217 ;; a string, then encode its size, then serialize its fields
218 (let ((tag (make-tag $wire-type-string (proto-index field)))
219 (len (cached-object-size v visited)))
220 (setq index (encode-uint32 tag buffer index))
221 (setq index (encode-uint32 len buffer index)))
222 (dolist (f (proto-fields msg))
223 (do-field v msg f)))))
224 ((typep msg 'protobuf-enum)
225 (let ((tag (make-tag $wire-type-varint (proto-index field))))
226 ;; 'proto-packed-p' of enum types returns nil,
227 ;; so packed enum fields won't be handled above
228 (if (proto-packed field)
229 (setq index (serialize-packed-enum (read-slot object slot reader)
230 (proto-values msg) tag buffer index))
231 (doseq (v (read-slot object slot reader))
232 (setq index (serialize-enum v (proto-values msg) tag buffer index))))))
233 ((typep msg 'protobuf-type-alias)
234 (let* ((type (proto-proto-type msg))
235 (tag (make-tag type (proto-index field))))
236 (doseq (v (read-slot object slot reader))
237 (let ((v (funcall (proto-serializer msg) v)))
238 (setq index (serialize-prim v type tag buffer index))))))
240 (undefined-field-type "While serializing ~S,"
241 object type field))))
243 (cond ((eq type :bool)
244 ;; We have to handle optional boolean fields specially
245 ;; because "false" and nil are the same value in Lisp
246 (let ((v (cond ((or (eq (proto-required field) :required)
248 (read-slot object slot reader))
249 ((slot-boundp object slot)
250 (read-slot object slot reader))
252 (unless (eq v :unbound)
253 (let ((tag (make-tag :bool (proto-index field))))
254 (setq index (serialize-prim v type tag buffer index))))))
256 (let ((v (read-slot object slot reader)))
257 (when (and v (not (equal v (proto-default field))))
258 (let ((tag (make-tag type (proto-index field))))
259 (setq index (serialize-prim v type tag buffer index))))))
260 ((typep (setq msg (and type (or (find-message trace type)
261 (find-enum trace type)
262 (find-type-alias trace type))))
264 (let ((v (if slot (read-slot object slot reader) object)))
266 (if (eq (proto-message-type msg) :group)
267 (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
268 (tag2 (make-tag $wire-type-end-group (proto-index field))))
269 (setq index (encode-uint32 tag1 buffer index))
270 (dolist (f (proto-fields msg))
272 (setq index (encode-uint32 tag2 buffer index)))
273 (let ((tag (make-tag $wire-type-string (proto-index field)))
274 (len (cached-object-size v visited)))
275 (setq index (encode-uint32 tag buffer index))
276 (setq index (encode-uint32 len buffer index))
277 (dolist (f (proto-fields msg))
278 (do-field v msg f)))))))
279 ((typep msg 'protobuf-enum)
280 (let ((v (read-slot object slot reader)))
281 (when (and v (not (eql v (proto-default field))))
282 (let ((tag (make-tag $wire-type-varint (proto-index field))))
283 (setq index (serialize-enum v (proto-values msg) tag buffer index))))))
284 ((typep msg 'protobuf-type-alias)
285 (let ((v (read-slot object slot reader)))
287 (let* ((v (funcall (proto-serializer msg) v))
288 (type (proto-proto-type msg))
289 (tag (make-tag type (proto-index field))))
290 (setq index (serialize-prim v type tag buffer index))))))
292 (undefined-field-type "While serializing ~S,"
293 object type field)))))))))
294 (declare (dynamic-extent #'do-field))
295 (dolist (field (proto-fields message))
296 (do-field object message field))))
297 (values buffer index)))
302 (defun deserialize-object-from-file (type filename)
303 "Deserializes an object of the given type 'type' from the given file
304 as a Protobuf object."
305 (with-open-file (stream filename
307 :element-type '(unsigned-byte 8))
308 (deserialize-object-from-stream type :stream stream)))
310 (defun deserialize-object-from-stream (type &key (stream *standard-input*))
311 "Deserializes an object of the given type 'type' from the given stream
312 as a Protobuf object."
313 (let* ((size (file-length stream))
314 (buffer (make-byte-vector size)))
315 (read-sequence buffer stream)
316 (deserialize-object type buffer 0 size)))
318 (defun deserialize-object-from-bytes (type buffer)
319 "Deserializes an object of the given type 'type' from the given stream
320 as a Protobuf object.
321 'type' is the Lisp name of a Protobufs message (usually the name of a
322 Lisp class) or a 'protobuf-message'.
323 The return value is the object."
324 (deserialize-object type buffer))
326 ;; Allow clients to add their own methods
327 ;; This is you might preserve object identity, e.g.
328 (defgeneric deserialize-object (type buffer &optional start end end-tag)
330 "Deserializes an object of the given type 'type' as a Protobufs object.
331 'type' is the Lisp name of a Protobufs message (usually the name of a
332 Lisp class) or a 'protobuf-message'.
333 The encoded bytes are in the byte array given by 'buffer' starting at
334 the fixnum index 'start' up to the end of the buffer, given by 'end'.
335 'start' defaults to 0, 'end' defaults to the length of the buffer.
336 'end-tag' is used internally to handle the (deprecated) \"group\" feature.
337 The return values are the object and the index at which deserialization stopped.."))
339 (defmethod deserialize-object (type buffer &optional start end (end-tag 0))
340 (let ((message (find-message-for-class type)))
342 (serialization-error "There is no Protobuf message having the type ~S" type))
344 (deserialize-object message buffer start end end-tag)
346 (serialization-error "Error deserializing buffer ~S: ~A" buffer (princ-to-string e))))))
348 ;; The default method uses metadata from the protobuf "schema" for the message
349 ;;--- Maybe complain if there were any unsent required fields (see 'object-initialized-p'),
350 ;;--- but Lisp itself will complain if you try to access them, so not critical
351 (defmethod deserialize-object ((message protobuf-message) buffer &optional start end (end-tag 0))
352 (declare (type (simple-array (unsigned-byte 8)) buffer))
353 (let ((index (or start 0))
354 (length (or end (length buffer))))
355 (declare (type fixnum index length))
356 (macrolet ((read-slot (object slot reader)
358 (funcall ,reader ,object)
359 (slot-value ,object ,slot)))
360 (write-slot (object slot writer value)
362 `(let ((,vval ,value))
364 (funcall ,writer ,object ,vval)
365 (setf (slot-value ,object ,slot) ,vval)))))
366 (push-slot (object slot reader writer value)
367 (with-gensyms (vvals)
368 `(let ((,vvals (read-slot ,object ,slot ,reader)))
369 (if (i= (length ,vvals) 0)
370 ;; We need the initial value to be a stretchy vector,
371 ;; so scribble over it just to make sure
372 (let ((,vvals (make-array 1
373 :fill-pointer t :adjustable t
374 :initial-contents (list ,value))))
375 (write-slot ,object ,slot ,writer ,vvals))
376 (vector-push-extend ,value ,vvals))))))
377 (labels ((deserialize (type trace end end-tag)
378 (declare (type fixnum end end-tag))
379 (let* ((message (find-message trace type))
381 (make-instance (or (proto-alias-for message) (proto-class message)))))
382 ;; All the slots into which we store a repeated element
383 ;; These will be reversed at the end of deserialization
386 (multiple-value-bind (tag idx)
387 (if (i< index end) (decode-uint32 buffer index) (values 0 index))
388 ;; We're done if we've gotten to the end index or
389 ;; we see an end tag that matches a previous group's start tag
390 ;; Note that the default end tag is 0, which is also an end of
391 ;; message marker (there can never be "real" zero tags because
392 ;; field indices start at 1)
394 (when (i= tag end-tag)
395 ;; Reverse the repeated slots
396 (dolist (field rslots)
397 (let ((slot (proto-value field))
398 (reader (proto-reader field))
399 (writer (proto-writer field)))
400 (write-slot object slot writer
401 (nreverse (read-slot object slot reader)))))
402 (return-from deserialize
403 (values object index)))
404 (let* ((fidx (ilogand (iash tag -3) #x1FFFFFFF))
405 (field (find fidx (proto-fields message) :key #'proto-index))
406 (type (and field (if (eq (proto-class field) 'boolean) :bool (proto-class field))))
407 ;; It's OK for this to be null
408 ;; That means we're parsing some version of a message
409 ;; that has the field, but our current message does not
410 ;; We still have to deserialize everything, though
411 (slot (and field (proto-value field)))
412 (reader (and field (proto-reader field)))
413 (writer (and field (proto-writer field)))
416 ;; If there's no field descriptor for this index, just skip
417 ;; the next element in the buffer having the given wire type
418 (setq index (skip-element buffer index tag))
419 ;; We don't explicitly check for mismatched wire type, running past the
420 ;; end of the buffer, etc; instead, we'll count on the high likelihood
421 ;; of some kind of an error getting signalled (e.g., array out of bounds)
422 ;; and catch it at a higher level. Yay, Lisp!
423 (cond ((and field (eq (proto-required field) :repeated))
424 (let ((vectorp (vector-field-p field)))
425 (cond ((and (proto-packed field) (packed-type-p type))
426 (multiple-value-bind (values idx)
427 (deserialize-packed type buffer index)
430 (let ((values (make-array (length values)
431 :fill-pointer t :adjustable t
432 :initial-contents values)))
433 (write-slot object slot writer values))
434 (write-slot object slot writer values))))
436 (multiple-value-bind (val idx)
437 (deserialize-prim type buffer index)
440 (push-slot object slot reader writer val))
442 (pushnew field rslots)
443 ;; This "push" could type-check the entire list if
444 ;; there's a parameterized list type in effect,
445 ;; so you'll want to avoid using such types
446 ;; We'll reverse the slots at the last minute
447 (write-slot object slot writer
448 (cons val (read-slot object slot reader)))))))
449 ((typep (setq msg (and type (or (find-message trace type)
450 (find-enum trace type)
451 (find-type-alias trace type))))
453 (if (eq (proto-message-type msg) :group)
454 (let* ((etag (make-tag $wire-type-end-group fidx))
455 (obj (deserialize type msg length etag)))
457 (push-slot object slot reader writer obj))
459 (pushnew field rslots)
460 (write-slot object slot writer
461 (cons obj (read-slot object slot reader))))))
462 (multiple-value-bind (len idx)
463 (decode-uint32 buffer index)
465 (let ((obj (deserialize type msg (+ index len) 0)))
467 (push-slot object slot reader writer obj))
469 (pushnew field rslots)
470 (write-slot object slot writer
471 (cons obj (read-slot object slot reader)))))))))
472 ((typep msg 'protobuf-enum)
473 (if (proto-packed field)
474 (multiple-value-bind (values idx)
475 (deserialize-packed-enum (proto-values msg) buffer index)
478 (let ((values (make-array (length values)
479 :fill-pointer t :adjustable t
480 :initial-contents values)))
481 (write-slot object slot writer values))
482 (write-slot object slot writer values)))
483 (multiple-value-bind (val idx)
484 (deserialize-enum (proto-values msg) buffer index)
487 (push-slot object slot reader writer val))
489 (pushnew field rslots)
490 (write-slot object slot writer
491 (cons val (read-slot object slot reader))))))))
492 ((typep msg 'protobuf-type-alias)
493 (let ((type (proto-proto-type msg)))
494 (multiple-value-bind (val idx)
495 (deserialize-prim type buffer index)
498 (push-slot object slot reader writer
499 (funcall (proto-deserializer msg) val)))
501 (pushnew field rslots)
502 (write-slot object slot writer
503 (cons (funcall (proto-deserializer msg) val)
504 (read-slot object slot reader)))))))))))
506 (cond ((keywordp type)
507 (multiple-value-bind (val idx)
508 (deserialize-prim type buffer index)
510 (write-slot object slot writer val)))
511 ((typep (setq msg (and type (or (find-message trace type)
512 (find-enum trace type)
513 (find-type-alias trace type))))
515 ;;--- If there's already a value in the slot, merge messages
516 (if (eq (proto-message-type msg) :group)
517 (let* ((etag (make-tag $wire-type-end-group fidx))
518 (obj (deserialize type msg length etag)))
519 (write-slot object slot writer obj))
520 (multiple-value-bind (len idx)
521 (decode-uint32 buffer index)
523 (let ((obj (deserialize type msg (+ index len) 0)))
524 (write-slot object slot writer obj)))))
525 ((typep msg 'protobuf-enum)
526 (multiple-value-bind (val idx)
527 (deserialize-enum (proto-values msg) buffer index)
529 (write-slot object slot writer val)))
530 ((typep msg 'protobuf-type-alias)
531 (let ((type (proto-proto-type msg)))
532 (multiple-value-bind (val idx)
533 (deserialize-prim type buffer index)
535 (write-slot object slot writer
536 (funcall (proto-deserializer msg) val)))))))))))))))
537 (declare (dynamic-extent #'deserialize))
538 (deserialize (proto-class message) message length end-tag)))))
543 ;; Allow clients to add their own methods
544 ;; This is how we address the problem of cycles, e.g. -- if you have an object
545 ;; that may contain cycles, return the size of the "handle" to the object
546 (defgeneric object-size (object type &optional visited)
548 "Computes the size in bytes of the object 'object' of type 'type'.
549 'type' is the Lisp name of a Protobufs message (usually the name of a
550 Lisp class) or a 'protobuf-message'.
551 'visited' is either a hash table used to cache object sizes,
552 or is nil, in which case the objects must have a '%cached-size' slot in them.
553 The return value is the size of the object in bytes."))
555 (defmethod object-size (object type &optional visited)
556 (let ((message (find-message-for-class type)))
558 (serialization-error "There is no Protobuf message having the type ~S" type))
559 (object-size object message visited)))
561 ;; 'visited' is used to cache object sizes
562 ;; The default method uses metadata from the protobuf "schema" for the message
563 (defmethod object-size (object (message protobuf-message) &optional visited)
565 (declare (type fixnum size))
566 (macrolet ((read-slot (object slot reader)
567 ;; Don't do a boundp check, we assume the object is fully populated
568 ;; Unpopulated slots should be "nullable" and will contain nil when empty
570 (funcall ,reader ,object)
571 (slot-value ,object ,slot))))
572 (labels ((do-field (object trace field)
573 ;; We don't do cycle detection here
574 ;; If the client needs it, he can define his own 'object-size'
575 ;; method to clean things up first
576 (let* ((type (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
577 (slot (proto-value field))
578 (reader (proto-reader field))
580 (when (or slot reader)
581 (cond ((eq (proto-required field) :repeated)
582 (cond ((and (proto-packed field) (packed-type-p type))
583 (let ((tag (make-tag type (proto-index field))))
584 (iincf size (packed-size (read-slot object slot reader) type tag))))
586 (let ((tag (make-tag type (proto-index field))))
587 (doseq (v (read-slot object slot reader))
588 (iincf size (prim-size v type tag)))))
589 ((typep (setq msg (and type (or (find-message trace type)
590 (find-enum trace type)
591 (find-type-alias trace type))))
593 (if (eq (proto-message-type msg) :group)
594 (doseq (v (if slot (read-slot object slot reader) (list object)))
595 (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
596 (tag2 (make-tag $wire-type-end-group (proto-index field))))
597 (iincf size (varint-length tag1))
598 (dolist (f (proto-fields msg))
600 (iincf size (varint-length tag2))))
601 (doseq (v (if slot (read-slot object slot reader) (list object)))
602 (let ((tag (make-tag $wire-type-string (proto-index field)))
603 (len (or (cached-object-size v visited)
604 (object-size v msg visited))))
605 (iincf size (varint-length tag))
606 (iincf size (varint-length len))
607 (dolist (f (proto-fields msg))
608 (do-field v msg f))))))
609 ((typep msg 'protobuf-enum)
610 (let ((tag (make-tag $wire-type-varint (proto-index field))))
611 (if (proto-packed field)
612 (iincf size (packed-enum-size (read-slot object slot reader) type tag))
613 (doseq (v (read-slot object slot reader))
614 (iincf size (enum-size v (proto-values msg) tag))))))
615 ((typep msg 'protobuf-type-alias)
616 (let* ((type (proto-proto-type msg))
617 (tag (make-tag type (proto-index field))))
618 (doseq (v (read-slot object slot reader))
619 (let ((v (funcall (proto-serializer msg) v)))
620 (iincf size (prim-size v type tag))))))
622 (undefined-field-type "While computing the size of ~S,"
623 object type field))))
625 (cond ((eq type :bool)
626 (let ((v (cond ((or (eq (proto-required field) :required)
628 (read-slot object slot reader))
629 ((slot-boundp object slot)
630 (read-slot object slot reader))
632 (unless (eq v :unbound)
633 (let ((tag (make-tag :bool (proto-index field))))
634 (iincf size (prim-size v type tag))))))
636 (let ((v (read-slot object slot reader)))
637 (when (and v (not (equal v (proto-default field))))
638 (let ((tag (make-tag type (proto-index field))))
639 (iincf size (prim-size v type tag))))))
640 ((typep (setq msg (and type (or (find-message trace type)
641 (find-enum trace type)
642 (find-type-alias trace type))))
644 (let ((v (if slot (read-slot object slot reader) object)))
646 (if (eq (proto-message-type msg) :group)
647 (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
648 (tag2 (make-tag $wire-type-end-group (proto-index field))))
649 (iincf size (varint-length tag1))
650 (dolist (f (proto-fields msg))
652 (iincf size (varint-length tag2)))
653 (let ((tag (make-tag $wire-type-string (proto-index field)))
654 (len (or (cached-object-size v visited)
655 (object-size v msg visited))))
656 (iincf size (varint-length tag))
657 (iincf size (varint-length len))
658 (dolist (f (proto-fields msg))
659 (do-field v msg f)))))))
660 ((typep msg 'protobuf-enum)
661 (let ((v (read-slot object slot reader)))
662 (when (and v (not (eql v (proto-default field))))
663 (let ((tag (make-tag $wire-type-varint (proto-index field))))
664 (iincf size (enum-size (read-slot object slot reader) (proto-values msg) tag))))))
665 ((typep msg 'protobuf-type-alias)
666 (let ((v (read-slot object slot reader)))
668 (let* ((v (funcall (proto-serializer msg) v))
669 (type (proto-proto-type msg))
670 (tag (make-tag type (proto-index field))))
671 (iincf size (prim-size v type tag))))))
673 (undefined-field-type "While computing the size of ~S,"
674 object type field)))))))))
675 (declare (dynamic-extent #'do-field))
676 (dolist (field (proto-fields message))
677 (do-field object message field))
678 (setf (cached-object-size object visited) size) ;cache the size
682 ;;; Compile-time generation of serializers
683 ;;; Type-checking is done at the top-level methods specialized on 'symbol',
684 ;;; so we turn off all type checking at the level of these functions
686 ;; Note well: keep this in sync with the main 'serialize-object' method above
687 (defun generate-serializer (message)
688 "Generate a 'serialize-object' method for the given message."
689 (with-gensyms (vobj vbuf vidx vval vclass)
690 (when (null (proto-fields message))
691 (return-from generate-serializer
692 `(defmethod serialize-object
693 (,vobj (,vclass (eql ,message)) ,vbuf &optional (,vidx 0) visited)
694 (declare #.$optimize-serialization)
695 (declare (ignorable ,vobj ,vclass visited)
696 (type (simple-array (unsigned-byte 8)) ,vbuf)
698 (values ,vbuf ,vidx))))
699 (with-collectors ((serializers collect-serializer))
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 (find-type-alias message class))))
706 (reader (cond ((proto-reader field)
707 `(,(proto-reader field) ,vobj))
709 `(slot-value ,vobj ',(proto-value field)))))
710 (index (proto-index field)))
712 (cond ((eq (proto-required field) :repeated)
713 (let* ((vectorp (vector-field-p field))
714 (iterator (if vectorp 'dovector 'dolist)))
715 (cond ((and (proto-packed field) (packed-type-p class))
717 (let ((tag (make-tag class index)))
718 `(setq ,vidx (serialize-packed ,reader ,class ,tag ,vbuf ,vidx
722 (let ((tag (make-tag class index)))
723 `(,iterator (,vval ,reader)
724 (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))))
725 ((typep msg 'protobuf-message)
727 (if (eq (proto-message-type msg) :group)
728 (let ((tag1 (make-tag $wire-type-start-group index))
729 (tag2 (make-tag $wire-type-end-group index)))
730 `(,iterator (,vval ,reader)
731 (let ((len (cached-object-size ,vval visited)))
732 (setq ,vidx (encode-uint32 ,tag1 ,vbuf ,vidx))
733 (serialize-object ,vval ,msg ,vbuf ,vidx visited)
735 (setq ,vidx (encode-uint32 ,tag2 ,vbuf ,vidx)))))
736 (let ((tag (make-tag $wire-type-string index)))
737 `(,iterator (,vval ,reader)
738 (let ((len (cached-object-size ,vval visited)))
739 (setq ,vidx (encode-uint32 ,tag ,vbuf ,vidx))
740 (setq ,vidx (encode-uint32 len ,vbuf ,vidx))
741 (serialize-object ,vval ,msg ,vbuf ,vidx visited)
742 (iincf ,vidx len)))))))
743 ((typep msg 'protobuf-enum)
745 (let ((tag (make-tag $wire-type-varint index)))
746 (if (proto-packed field)
747 `(setq ,vidx (serialize-packed-enum ,reader '(,@(proto-values msg)) ,tag ,vbuf ,vidx
750 `(,iterator (,vval ,reader)
751 (setq ,vidx (serialize-enum ,vval '(,@(proto-values msg)) ,tag ,vbuf ,vidx)))))))
752 ((typep msg 'protobuf-type-alias)
754 (let* ((class (proto-proto-type msg))
755 (tag (make-tag class (proto-index field))))
756 `(,iterator (,vval ,reader)
757 (let ((,vval (funcall #',(proto-serializer msg) ,vval)))
758 (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx)))))))
760 (undefined-field-type "While generating 'serialize-object' for ~S,"
761 message class field)))))
763 (cond ((keywordp class)
765 (let ((tag (make-tag class index)))
767 (if (or (eq (proto-required field) :required)
768 (null (proto-value field)))
769 `(let ((,vval ,reader))
770 (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx)))
771 `(let ((,vval (cond ((slot-boundp ,vobj ',(proto-value field))
774 (unless (eq ,vval :unbound)
775 (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx)))))
776 (if (empty-default-p field)
777 `(let ((,vval ,reader))
779 (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))
780 `(let ((,vval ,reader))
781 (when (and ,vval (not (equal ,vval ',(proto-default field))))
782 (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx)))))))))
783 ((typep msg 'protobuf-message)
785 (if (eq (proto-message-type msg) :group)
786 (let ((tag1 (make-tag $wire-type-start-group index))
787 (tag2 (make-tag $wire-type-end-group index)))
788 `(let ((,vval ,reader))
790 (let ((len (cached-object-size ,vval visited)))
791 (setq ,vidx (encode-uint32 ,tag1 ,vbuf ,vidx))
792 (serialize-object ,vval ,msg ,vbuf ,vidx visited)
794 (setq ,vidx (encode-uint32 ,tag2 ,vbuf ,vidx))))))
795 (let ((tag (make-tag $wire-type-string index)))
796 `(let ((,vval ,reader))
798 (let ((len (cached-object-size ,vval visited)))
799 (setq ,vidx (encode-uint32 ,tag ,vbuf ,vidx))
800 (setq ,vidx (encode-uint32 len ,vbuf ,vidx))
801 (serialize-object ,vval ,msg ,vbuf ,vidx visited)
802 (iincf ,vidx len))))))))
803 ((typep msg 'protobuf-enum)
805 (let ((tag (make-tag $wire-type-varint index)))
806 (if (empty-default-p field)
807 `(let ((,vval ,reader))
809 (setq ,vidx (serialize-enum ,vval '(,@(proto-values msg)) ,tag ,vbuf ,vidx))))
810 `(let ((,vval ,reader))
811 (when (and ,vval (not (eql ,vval ',(proto-default field))))
812 (setq ,vidx (serialize-enum ,vval '(,@(proto-values msg)) ,tag ,vbuf ,vidx))))))))
813 ((typep msg 'protobuf-type-alias)
815 (let* ((class (proto-proto-type msg))
816 (tag (make-tag class (proto-index field))))
817 `(let ((,vval ,reader))
819 (let ((,vval (funcall #',(proto-serializer msg) ,vval)))
820 (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))))))
822 (undefined-field-type "While generating 'serialize-object' for ~S,"
823 message class field))))))))
824 `(defmethod serialize-object
825 (,vobj (,vclass (eql ,message)) ,vbuf &optional (,vidx 0) visited)
826 (declare #.$optimize-serialization)
827 (declare (ignorable visited)
828 (type (simple-array (unsigned-byte 8)) ,vbuf)
831 (values ,vbuf ,vidx)))))
833 ;; Note well: keep this in sync with the main 'deserialize-object' method above
834 (defun generate-deserializer (message)
835 "Generate a 'deserialize-object' method for the given message."
836 (with-gensyms (vclass vbuf vidx vlen vendtag vobj vval)
837 (when (null (proto-fields message))
838 (return-from generate-deserializer
839 `(defmethod deserialize-object
840 ((,vclass (eql ,message)) ,vbuf &optional ,vidx ,vlen (,vendtag 0))
841 (declare #.$optimize-serialization)
842 (declare (ignorable ,vclass ,vbuf ,vlen ,vendtag)
843 (type (simple-array (unsigned-byte 8)) ,vbuf))
844 (let ((,vidx (or ,vidx 0)))
845 (declare (type fixnum ,vidx))
846 (let ((,vobj (make-instance ',(or (proto-alias-for message) (proto-class message)))))
847 (values ,vobj ,vidx))))))
848 (with-collectors ((deserializers collect-deserializer)
849 ;; For tracking repeated slots that will need to be reversed
850 (rslots collect-rslot))
851 (flet ((read-slot (object field)
852 (cond ((proto-reader field)
853 `(,(proto-reader field) ,object))
855 `(slot-value ,object ',(proto-value field)))))
856 (write-slot (object field value)
857 (cond ((proto-writer field)
858 `(,(proto-writer field) ,object ,value))
860 `(setf (slot-value ,object ',(proto-value field)) ,value)))))
861 (dolist (field (proto-fields message))
862 (let* ((class (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
863 (msg (and class (not (keywordp class))
864 (or (find-message message class)
865 (find-enum message class)
866 (find-type-alias message class))))
867 (index (proto-index field)))
868 (cond ((eq (proto-required field) :repeated)
869 (cond ((and (proto-packed field) (packed-type-p class))
870 (collect-deserializer
871 `((,(make-tag class index))
872 (multiple-value-bind (,vval idx)
873 (deserialize-packed ,class ,vbuf ,vidx)
875 ,@(when (vector-field-p field)
876 `((setq ,vval (make-array (length ,vval)
877 :fill-pointer t :adjustable t
878 :initial-contents ,vval))))
879 ,(write-slot vobj field vval)))))
881 (let ((temp (gensym (string (proto-value field)))))
882 (collect-rslot (list field temp))
883 (collect-deserializer
884 `((,(make-tag class index))
885 (multiple-value-bind (,vval idx)
886 (deserialize-prim ,class ,vbuf ,vidx)
888 (push ,vval ,temp))))))
889 ((typep msg 'protobuf-message)
890 (let ((temp (gensym (string (proto-value field)))))
891 (collect-rslot (list field temp))
892 (collect-deserializer
893 (if (eq (proto-message-type msg) :group)
894 `((,(make-tag $wire-type-start-group index))
895 (multiple-value-bind (,vval idx)
896 (deserialize-object ,msg ,vbuf ,vidx ,vlen
897 ,(make-tag $wire-type-end-group index))
900 `((,(make-tag $wire-type-string index))
901 (multiple-value-bind (len idx)
902 (decode-uint32 ,vbuf ,vidx)
904 (multiple-value-bind (,vval idx)
905 (deserialize-object ,msg ,vbuf ,vidx (i+ ,vidx len) 0)
907 (push ,vval ,temp))))))))
908 ((typep msg 'protobuf-enum)
909 (if (proto-packed field)
910 (collect-deserializer
911 `((,(make-tag $wire-type-varint index))
912 (multiple-value-bind (,vval idx)
913 (deserialize-packed-enum '(,@(proto-values msg)) ,vbuf ,vidx)
915 ,(write-slot vobj field vval))))
916 (let ((temp (gensym (string (proto-value field)))))
917 (collect-rslot (list field temp))
918 (collect-deserializer
919 `((,(make-tag $wire-type-varint index))
920 (multiple-value-bind (,vval idx)
921 (deserialize-enum '(,@(proto-values msg)) ,vbuf ,vidx)
923 (push ,vval ,temp)))))))
924 ((typep msg 'protobuf-type-alias)
925 (let ((class (proto-proto-type msg))
926 (temp (gensym (string (proto-value field)))))
927 (collect-rslot (list field temp))
928 (collect-deserializer
929 `((,(make-tag class index))
930 (multiple-value-bind (,vval idx)
931 (deserialize-prim ,class ,vbuf ,vidx)
933 (push (funcall #',(proto-deserializer msg) ,vval) ,temp))))))
935 (undefined-field-type "While generating 'deserialize-object' for ~S,"
936 message class field))))
938 (cond ((keywordp class)
939 (collect-deserializer
940 `((,(make-tag class index))
941 (multiple-value-bind (,vval idx)
942 (deserialize-prim ,class ,vbuf ,vidx)
944 ,(write-slot vobj field vval)))))
945 ((typep msg 'protobuf-message)
946 (collect-deserializer
947 (if (eq (proto-message-type msg) :group)
948 `((,(make-tag $wire-type-start-group index))
949 (multiple-value-bind (,vval idx)
950 (deserialize-object ,msg ,vbuf ,vidx ,vlen
951 ,(make-tag $wire-type-end-group index))
953 ,(write-slot vobj field vval)))
954 `((,(make-tag $wire-type-string index))
955 (multiple-value-bind (len idx)
956 (decode-uint32 ,vbuf ,vidx)
958 (multiple-value-bind (,vval idx)
959 (deserialize-object ,msg ,vbuf ,vidx (i+ ,vidx len) 0)
961 ,(write-slot vobj field vval)))))))
962 ((typep msg 'protobuf-enum)
963 (collect-deserializer
964 `((,(make-tag $wire-type-varint index))
965 (multiple-value-bind (,vval idx)
966 (deserialize-enum '(,@(proto-values msg)) ,vbuf ,vidx)
968 ,(write-slot vobj field vval)))))
969 ((typep msg 'protobuf-type-alias)
970 (let ((class (proto-proto-type msg)))
971 (collect-deserializer
972 `((,(make-tag class index))
973 (multiple-value-bind (,vval idx)
974 (deserialize-prim ,class ,vbuf ,vidx)
975 (let ((,vval (funcall #',(proto-deserializer msg) ,vval)))
977 ,(write-slot vobj field vval)))))))
979 (undefined-field-type "While generating 'deserialize-object' for ~S,"
980 message class field))))))))
981 (let* ((rslots (delete-duplicates rslots :key #'first))
982 (rfields (mapcar #'first rslots))
983 (rtemps (mapcar #'second rslots)))
984 `(defmethod deserialize-object
985 ((,vclass (eql ,message)) ,vbuf &optional ,vidx ,vlen (,vendtag 0))
986 (declare #.$optimize-serialization)
987 (declare (type (simple-array (unsigned-byte 8)) ,vbuf))
988 (let ((,vidx (or ,vidx 0))
989 (,vlen (or ,vlen (length ,vbuf))))
990 (declare (type fixnum ,vidx ,vlen))
991 (let ((,vobj (make-instance ',(or (proto-alias-for message) (proto-class message))))
992 ;; Bind the temporary variables that hold repeated slots
995 (multiple-value-bind (tag idx)
996 (if (i< ,vidx ,vlen) (decode-uint32 ,vbuf ,vidx) (values 0 ,vidx))
998 (when (i= tag ,vendtag)
999 ;; Set the (un)reversed values of the repeated slots
1000 ,@(loop for field in rfields
1002 as slot = (proto-value field)
1003 as writer = (proto-writer field)
1004 collect (cond ((vector-field-p field)
1006 `(funcall ,writer ,vobj (make-array (length ,temp)
1007 :fill-pointer t :adjustable t
1008 :initial-contents (nreverse ,temp)))
1009 `(setf (slot-value ,vobj ',slot) (make-array (length ,temp)
1010 :fill-pointer t :adjustable t
1011 :initial-contents (nreverse ,temp)))))
1014 `(funcall ,writer ,vobj (nreverse ,temp))
1015 `(setf (slot-value ,vobj ',slot) (nreverse ,temp))))))
1016 (return-from deserialize-object
1017 (values ,vobj ,vidx)))
1021 (setq ,vidx (skip-element ,vbuf ,vidx tag)))))))))))))
1023 ;; Note well: keep this in sync with the main 'object-size' method above
1024 (defun generate-object-size (message)
1025 "Generate an 'object-size' method for the given message."
1026 (with-gensyms (vobj vsize vval vclass)
1027 (when (null (proto-fields message))
1028 (return-from generate-object-size
1029 `(defmethod object-size
1030 (,vobj (,vclass (eql ,message)) &optional visited)
1031 (declare #.$optimize-serialization)
1032 (setf (cached-object-size ,vobj visited) 0)
1034 (with-collectors ((sizers collect-sizer))
1035 (dolist (field (proto-fields message))
1036 (let* ((class (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
1037 (msg (and class (not (keywordp class))
1038 (or (find-message message class)
1039 (find-enum message class)
1040 (find-type-alias message class))))
1041 (reader (cond ((proto-reader field)
1042 `(,(proto-reader field) ,vobj))
1043 ((proto-value field)
1044 `(slot-value ,vobj ',(proto-value field)))))
1045 (index (proto-index field)))
1047 (cond ((eq (proto-required field) :repeated)
1048 (let* ((vectorp (vector-field-p field))
1049 (iterator (if vectorp 'dovector 'dolist)))
1050 (cond ((and (proto-packed field) (packed-type-p class))
1052 (let ((tag (make-tag class index)))
1053 `(iincf ,vsize (packed-size ,reader ,class ,tag ,vectorp)))))
1056 (let ((tag (make-tag class index)))
1057 `(,iterator (,vval ,reader)
1058 (iincf ,vsize (prim-size ,vval ,class ,tag))))))
1059 ((typep msg 'protobuf-message)
1061 (if (eq (proto-message-type msg) :group)
1062 (let ((tag1 (make-tag $wire-type-start-group index))
1063 (tag2 (make-tag $wire-type-end-group index)))
1064 `(,iterator (,vval ,reader)
1065 (let ((len (or (cached-object-size ,vval visited)
1066 (object-size ,vval ,msg visited))))
1067 (iincf ,vsize (varint-length ,tag1))
1069 (iincf ,vsize ,tag2))))
1070 (let ((tag (make-tag $wire-type-string index)))
1071 `(,iterator (,vval ,reader)
1072 (let ((len (or (cached-object-size ,vval visited)
1073 (object-size ,vval ,msg visited))))
1074 (iincf ,vsize (varint-length ,tag))
1075 (iincf ,vsize (varint-length len))
1076 (iincf ,vsize len)))))))
1077 ((typep msg 'protobuf-enum)
1078 (let ((tag (make-tag $wire-type-varint index)))
1080 (if (proto-packed field)
1081 `(iincf ,vsize (packed-enum-size ,reader '(,@(proto-values msg)) ,tag))
1082 `(,iterator (,vval ,reader)
1083 (iincf ,vsize (enum-size ,vval '(,@(proto-values msg)) ,tag)))))))
1084 ((typep msg 'protobuf-type-alias)
1086 (let* ((class (proto-proto-type msg))
1087 (tag (make-tag class index)))
1088 `(,iterator (,vval ,reader)
1089 (let ((,vval (funcall #',(proto-serializer msg) ,vval)))
1090 (iincf ,vsize (prim-size ,vval ,class ,tag)))))))
1092 (undefined-field-type "While generating 'object-size' for ~S,"
1093 message class field)))))
1095 (cond ((keywordp class)
1096 (let ((tag (make-tag class index)))
1098 (if (eq class :bool)
1099 (if (or (eq (proto-required field) :required)
1100 (null (proto-value field)))
1101 `(let ((,vval ,reader))
1102 (declare (ignorable ,vval))
1103 (iincf ,vsize (prim-size ,vval ,class ,tag)))
1104 `(let ((,vval (cond ((slot-boundp ,vobj ',(proto-value field))
1107 (unless (eq ,vval :unbound)
1108 (iincf ,vsize (prim-size ,vval ,class ,tag)))))
1109 (if (empty-default-p field)
1110 `(let ((,vval ,reader))
1112 (iincf ,vsize (prim-size ,vval ,class ,tag))))
1113 `(let ((,vval ,reader))
1114 (when (and ,vval (not (equal ,vval ',(proto-default field))))
1115 (iincf ,vsize (prim-size ,vval ,class ,tag)))))))))
1116 ((typep msg 'protobuf-message)
1118 (if (eq (proto-message-type msg) :group)
1119 (let ((tag1 (make-tag $wire-type-start-group index))
1120 (tag2 (make-tag $wire-type-end-group index)))
1121 `(let ((,vval ,reader))
1123 (let ((len (or (cached-object-size ,vval visited)
1124 (object-size ,vval ,msg visited))))
1125 (iincf ,vsize (varint-length ,tag1))
1127 (iincf ,vsize (varint-length ,tag2))))))
1128 (let ((tag (make-tag $wire-type-string index)))
1129 `(let ((,vval ,reader))
1131 (let ((len (or (cached-object-size ,vval visited)
1132 (object-size ,vval ,msg visited))))
1133 (iincf ,vsize (varint-length ,tag))
1134 (iincf ,vsize (varint-length len))
1135 (iincf ,vsize len))))))))
1136 ((typep msg 'protobuf-enum)
1137 (let ((tag (make-tag $wire-type-varint index)))
1139 (if (empty-default-p field)
1140 `(let ((,vval ,reader))
1142 (iincf ,vsize (enum-size ,vval '(,@(proto-values msg)) ,tag))))
1143 `(let ((,vval ,reader))
1144 (when (and ,vval (not (eql ,vval ',(proto-default field))))
1145 (iincf ,vsize (enum-size ,vval '(,@(proto-values msg)) ,tag))))))))
1146 ((typep msg 'protobuf-type-alias)
1148 (let* ((class (proto-proto-type msg))
1149 (tag (make-tag class index)))
1150 `(let ((,vval ,reader))
1152 (iincf ,vsize (prim-size (funcall #',(proto-serializer msg) ,vval)
1155 (undefined-field-type "While generating 'object-size' for ~S,"
1156 message class field))))))))
1157 `(defmethod object-size
1158 (,vobj (,vclass (eql ,message)) &optional visited)
1159 (declare #.$optimize-serialization)
1160 (declare (ignorable visited))
1162 (declare (type fixnum ,vsize))
1164 (setf (cached-object-size ,vobj visited) ,vsize)