+ ((:string :bytes) $wire-type-string)
+ ((:bool) $wire-type-varint)
+ ((:float) $wire-type-32bit)
+ ((:double) $wire-type-64bit)
+ ;; A few of our homegrown types
+ ((:symbol) $wire-type-string)
+ ((:date :time :datetime :timestamp) $wire-type-64bit))))
+ (ilogior type (iash index 3))))))
+
+(define-compiler-macro make-tag (&whole form type index)
+ (setq type (fold-symbol type))
+ (cond ((typep type 'fixnum)
+ `(ilogior ,type (iash ,index 3)))
+ ((keywordp type)
+ (let ((type (ecase type
+ ((:int32 :uint32) $wire-type-varint)
+ ((:int64 :uint64) $wire-type-varint)
+ ((:sint32 :sint64) $wire-type-varint)
+ ((:fixed32 :sfixed32) $wire-type-32bit)
+ ((:fixed64 :sfixed64) $wire-type-64bit)
+ ((:string :bytes) $wire-type-string)
+ ((:bool) $wire-type-varint)
+ ((:float) $wire-type-32bit)
+ ((:double) $wire-type-64bit)
+ ;; A few of our homegrown types
+ ((:symbol) $wire-type-string)
+ ((:date :time :datetime :timestamp) $wire-type-64bit))))
+ `(ilogior ,type (iash ,index 3))))
+ (t form)))
+
+(defun fold-symbol (x)
+ "Given an expression 'x', constant-fold it until it can be folded no more."
+ (let ((last '#:last))
+ (loop
+ (cond ((eq x last) (return x))
+ ((and (listp x)
+ (eq (first x) 'quote)
+ (constantp (second x)))
+ (shiftf last x (second x)))
+ ((and (symbolp x)
+ (boundp x))
+ (shiftf last x (symbol-value x)))
+ (t (return x))))))
+
+
+(defmacro gen-zig-zag (bits)
+ "Generate 32- or 64-bit versions of zig-zag encoder/decoder."
+ (assert (and (plusp bits) (zerop (mod bits 8))))
+ (let* ((zig-zag-encode (fintern "~A~A" 'zig-zag-encode bits))
+ (zig-zag-decode (fintern "~A~A" 'zig-zag-decode bits))
+ (zig-zag-shift (1+ (- bits))))
+ `(progn
+ (defun ,zig-zag-encode (val)
+ (declare #.$optimize-serialization)
+ (declare (type (signed-byte ,bits) val))
+ (logxor (ash val 1) (ash val ,zig-zag-shift)))
+ (define-compiler-macro ,zig-zag-encode (&whole form val)
+ (if (atom val)
+ `(locally (declare #.$optimize-serialization
+ (type (signed-byte ,',bits) ,val))
+ (logxor (ash ,val 1) (ash ,val ,',zig-zag-shift)))
+ form))
+ (defun ,zig-zag-decode (val)
+ (declare #.$optimize-serialization)
+ (declare (type (unsigned-byte ,bits) val))
+ (logxor (ash val -1) (- (logand val 1))))
+ (define-compiler-macro ,zig-zag-decode (&whole form val)
+ (if (atom val)
+ `(locally (declare #.$optimize-serialization
+ (type (unsigned-byte ,',bits) ,val))
+ (logxor (ash ,val -1) (- (logand ,val 1))))
+ form)))))
+
+(gen-zig-zag 32)
+(gen-zig-zag 64)
+
+
+;;; Serializers
+
+;; Serialize 'val' of primitive type 'type' into the buffer
+(defun serialize-prim (val type tag buffer index)
+ "Serializes a Protobufs primitive (scalar) value into the buffer at the given index.
+ The value is given by 'val', the primitive type by 'type'.
+ Modifies the buffer in place, and returns the new index into the buffer.
+ Watch out, this function turns off most type checking and all array bounds checking."
+ (declare (type (unsigned-byte 32) tag)
+ (type fixnum index))
+ (locally (declare #.$optimize-serialization)
+ (let ((idx (encode-uint32 tag buffer index)))
+ (declare (type fixnum idx))
+ (ecase type
+ ((:int32 :uint32)
+ (encode-uint32 (ldb (byte 32 0) val) buffer idx))
+ ((:int64 :uint64)
+ (encode-uint64 (ldb (byte 64 0) val) buffer idx))
+ ((:sint32)
+ (encode-uint32 (zig-zag-encode32 val) buffer idx))
+ ((:sint64)
+ (encode-uint64 (zig-zag-encode64 val) buffer idx))
+ ((:fixed32)
+ (encode-fixed32 val buffer idx))
+ ((:sfixed32)
+ (encode-sfixed32 val buffer idx))
+ ((:fixed64)
+ (encode-fixed64 val buffer idx))
+ ((:sfixed64)
+ (encode-sfixed64 val buffer idx))
+ ((:string)
+ (encode-string val buffer idx))
+ ((:bytes)
+ (encode-octets val buffer idx))
+ ((:bool)
+ (encode-uint32 (if val 1 0) buffer idx))
+ ((:float)
+ (encode-single val buffer idx))
+ ((:double)
+ (encode-double val buffer idx))
+ ;; A few of our homegrown types
+ ((:symbol)
+ (let ((val (if (keywordp val)
+ (string val)
+ ;; Non-keyword symbols are consy, avoid them if possible
+ (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val)))))
+ (encode-string val buffer idx)))
+ ((:date :time :datetime :timestamp)
+ (encode-uint64 (ldb (byte 64 0) val) buffer idx))))))
+
+(define-compiler-macro serialize-prim (&whole form val type tag buffer index)
+ (setq type (fold-symbol type)
+ tag (fold-symbol tag))
+ (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
+ :fixed32 :sfixed32 :fixed64 :sfixed64
+ :string :bytes :bool :float :double))
+ `(locally (declare #.$optimize-serialization
+ (type (simple-array (unsigned-byte 8)) ,buffer)
+ ;; 'tag' is a constant, no need to declare its type
+ (type fixnum ,index))
+ (let ((idx (encode-uint32 ,tag ,buffer ,index)))
+ (declare (type fixnum idx))
+ ,(ecase type
+ ((:int32 )
+ `(encode-uint32 (ldb (byte 32 0) ,val) ,buffer idx))
+ ((:int64)
+ `(encode-uint64 (ldb (byte 64 0) ,val) ,buffer idx))
+ ((:uint32)
+ `(encode-uint32 ,val ,buffer idx))
+ ((:uint64)
+ `(encode-uint64 ,val ,buffer idx))
+ ((:sint32)
+ `(encode-uint32 (zig-zag-encode32 ,val) ,buffer idx))
+ ((:sint64)
+ `(encode-uint64 (zig-zag-encode64 ,val) ,buffer idx))
+ ((:fixed32)
+ `(encode-fixed32 ,val ,buffer idx))
+ ((:sfixed32)
+ `(encode-sfixed32 ,val ,buffer idx))
+ ((:fixed64)
+ `(encode-fixed64 ,val ,buffer idx))
+ ((:sfixed64)
+ `(encode-sfixed64 ,val ,buffer idx))
+ ((:string)
+ `(encode-string ,val ,buffer idx))
+ ((:bytes)
+ `(encode-octets ,val ,buffer idx))
+ ((:bool)
+ `(encode-uint32 (if ,val 1 0) ,buffer idx))
+ ((:float)
+ `(encode-single ,val ,buffer idx))
+ ((:double)
+ `(encode-double ,val ,buffer idx)))))
+ form))
+
+(defun serialize-packed (values type tag buffer index &optional vectorp)
+ "Serializes a set of packed values into the buffer at the given index.
+ The values are given by 'values', the primitive type by 'type'.
+ Modifies the buffer in place, and returns the new index into the buffer.
+ Watch out, this function turns off most type checking and all array bounds checking."
+ (declare (ignore vectorp)
+ (type (simple-array (unsigned-byte 8)) buffer)
+ (type (unsigned-byte 32) tag)
+ (type fixnum index))
+ (locally (declare #.$optimize-serialization)
+ (let ((idx (encode-uint32 tag buffer index)))
+ (declare (type fixnum idx))