type tag buffer index))))
((keywordp type)
(let ((tag (make-tag type (proto-index field))))
- (map () #'(lambda (v)
- (setq index (serialize-prim v type tag buffer index)))
- (read-slot object slot reader))))
+ (doseq (v (read-slot object slot reader))
+ (setq index (serialize-prim v type tag buffer index)))))
((typep (setq msg (and type (or (find-message trace type)
(find-enum trace type)
(find-type-alias trace type))))
'protobuf-message)
(if (eq (proto-message-type msg) :group)
- (map () #'(lambda (v)
- ;; To serialize a group, we encode a start tag,
- ;; serialize the fields, then encode an end tag
- (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
- (tag2 (make-tag $wire-type-end-group (proto-index field))))
- (setq index (encode-uint32 tag1 buffer index))
- (map () (curry #'do-field v msg)
- (proto-fields msg))
- (setq index (encode-uint32 tag2 buffer index))))
- (if slot (read-slot object slot reader) (list object)))
- (map () #'(lambda (v)
- ;; To serialize an embedded message, first say that it's
- ;; a string, then encode its size, then serialize its fields
- (let ((tag (make-tag $wire-type-string (proto-index field)))
- (len (object-size v msg visited)))
- (setq index (encode-uint32 tag buffer index))
- (setq index (encode-uint32 len buffer index)))
- (map () (curry #'do-field v msg)
- (proto-fields msg)))
- (if slot (read-slot object slot reader) (list object)))))
+ (doseq (v (if slot (read-slot object slot reader) (list object)))
+ ;; To serialize a group, we encode a start tag,
+ ;; serialize the fields, then encode an end tag
+ (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
+ (tag2 (make-tag $wire-type-end-group (proto-index field))))
+ (setq index (encode-uint32 tag1 buffer index))
+ (dolist (f (proto-fields msg))
+ (do-field v msg f))
+ (setq index (encode-uint32 tag2 buffer index))))
+ (doseq (v (if slot (read-slot object slot reader) (list object)))
+ ;; To serialize an embedded message, first say that it's
+ ;; a string, then encode its size, then serialize its fields
+ (let ((tag (make-tag $wire-type-string (proto-index field)))
+ (len (object-size v msg visited)))
+ (setq index (encode-uint32 tag buffer index))
+ (setq index (encode-uint32 len buffer index)))
+ (dolist (f (proto-fields msg))
+ (do-field v msg f)))))
((typep msg 'protobuf-enum)
(let ((tag (make-tag $wire-type-varint (proto-index field))))
;; 'proto-packed-p' of enum types returns nil,
(if (proto-packed field)
(setq index (serialize-packed-enum (read-slot object slot reader)
(proto-values msg) tag buffer index))
- (map () #'(lambda (v)
- (setq index (serialize-enum v (proto-values msg) tag buffer index)))
- (read-slot object slot reader)))))
+ (doseq (v (read-slot object slot reader))
+ (setq index (serialize-enum v (proto-values msg) tag buffer index))))))
((typep msg 'protobuf-type-alias)
(let* ((type (proto-proto-type msg))
(tag (make-tag type (proto-index field))))
- (map () #'(lambda (v)
- (let ((v (funcall (proto-serializer msg) v)))
- (setq index (serialize-prim v type tag buffer index))))
- (read-slot object slot reader))))))
+ (doseq (v (read-slot object slot reader))
+ (let ((v (funcall (proto-serializer msg) v)))
+ (setq index (serialize-prim v type tag buffer index))))))))
(t
(cond ((eq type :bool)
;; We have to handle optional boolean fields specially
(let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
(tag2 (make-tag $wire-type-end-group (proto-index field))))
(setq index (encode-uint32 tag1 buffer index))
- (map () (curry #'do-field v msg)
- (proto-fields msg))
+ (dolist (f (proto-fields msg))
+ (do-field v msg f))
(setq index (encode-uint32 tag2 buffer index)))
(let ((tag (make-tag $wire-type-string (proto-index field)))
(len (object-size v msg visited)))
(setq index (encode-uint32 tag buffer index))
(setq index (encode-uint32 len buffer index))
- (map () (curry #'do-field v msg)
- (proto-fields msg)))))))
+ (dolist (f (proto-fields msg))
+ (do-field v msg f)))))))
((typep msg 'protobuf-enum)
(let ((v (read-slot object slot reader)))
(when v
(tag (make-tag type (proto-index field))))
(setq index (serialize-prim v type tag buffer index)))))))))))))
(declare (dynamic-extent #'do-field))
- (map () (curry #'do-field object message) (proto-fields message))))
+ (dolist (field (proto-fields message))
+ (do-field object message field))))
(values buffer index)))
(iincf size (packed-size (read-slot object slot reader) type tag))))
((keywordp type)
(let ((tag (make-tag type (proto-index field))))
- (map () #'(lambda (v)
- (iincf size (prim-size v type tag)))
- (read-slot object slot reader))))
+ (doseq (v (read-slot object slot reader))
+ (iincf size (prim-size v type tag)))))
((typep (setq msg (and type (or (find-message trace type)
(find-enum trace type)
(find-type-alias trace type))))
'protobuf-message)
(if (eq (proto-message-type msg) :group)
- (map () #'(lambda (v)
- (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
- (tag2 (make-tag $wire-type-end-group (proto-index field))))
- (iincf size (length32 tag1))
- (map () (curry #'do-field v msg)
- (proto-fields msg))
- (iincf size (length32 tag2))))
- (if slot (read-slot object slot reader) (list object)))
- (map () #'(lambda (v)
- (let ((tag (make-tag $wire-type-string (proto-index field)))
- (len (object-size v msg visited)))
- (iincf size (length32 tag))
- (iincf size (length32 len))
- (map () (curry #'do-field v msg)
- (proto-fields msg))))
- (if slot (read-slot object slot reader) (list object)))))
+ (doseq (v (if slot (read-slot object slot reader) (list object)))
+ (let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
+ (tag2 (make-tag $wire-type-end-group (proto-index field))))
+ (iincf size (length32 tag1))
+ (dolist (f (proto-fields msg))
+ (do-field v msg f))
+ (iincf size (length32 tag2))))
+ (doseq (v (if slot (read-slot object slot reader) (list object)))
+ (let ((tag (make-tag $wire-type-string (proto-index field)))
+ (len (object-size v msg visited)))
+ (iincf size (length32 tag))
+ (iincf size (length32 len))
+ (dolist (f (proto-fields msg))
+ (do-field v msg f))))))
((typep msg 'protobuf-enum)
(let ((tag (make-tag $wire-type-varint (proto-index field))))
(if (proto-packed field)
(iincf size (packed-enum-size (read-slot object slot reader) type tag))
- (map () #'(lambda (v)
- (iincf size (enum-size v (proto-values msg) tag)))
- (read-slot object slot reader)))))
+ (doseq (v (read-slot object slot reader))
+ (iincf size (enum-size v (proto-values msg) tag))))))
((typep msg 'protobuf-type-alias)
(let* ((type (proto-proto-type msg))
(tag (make-tag type (proto-index field))))
- (map () #'(lambda (v)
- (let ((v (funcall (proto-serializer msg) v)))
- (iincf size (prim-size v type tag))))
- (read-slot object slot reader))))))
+ (doseq (v (read-slot object slot reader))
+ (let ((v (funcall (proto-serializer msg) v)))
+ (iincf size (prim-size v type tag))))))))
(t
(cond ((eq type :bool)
(let ((v (cond ((or (eq (proto-required field) :required)
(let ((tag1 (make-tag $wire-type-start-group (proto-index field)))
(tag2 (make-tag $wire-type-end-group (proto-index field))))
(iincf size (length32 tag1))
- (map () (curry #'do-field v msg)
- (proto-fields msg))
+ (dolist (f (proto-fields msg))
+ (do-field v msg f))
(iincf size (length32 tag2)))
(let ((tag (make-tag $wire-type-string (proto-index field)))
(len (object-size v msg visited)))
(iincf size (length32 tag))
(iincf size (length32 len))
- (map () (curry #'do-field v msg)
- (proto-fields msg)))))))
+ (dolist (f (proto-fields msg))
+ (do-field v msg f)))))))
((typep msg 'protobuf-enum)
(let ((v (read-slot object slot reader)))
(when v
(tag (make-tag type (proto-index field))))
(iincf size (prim-size v type tag)))))))))))))
(declare (dynamic-extent #'do-field))
- (map () (curry #'do-field object message) (proto-fields message))
+ (dolist (field (proto-fields message))
+ (do-field object message field))
(when visited
(setf (gethash object visited) size)) ;cache the size
size))))
(index (proto-index field)))
(when reader
(cond ((eq (proto-required field) :repeated)
- (let ((iterator (if (vector-field-p field) 'dovector 'dolist)))
+ (let* ((vectorp (vector-field-p field))
+ (iterator (if vectorp 'dovector 'dolist)))
(cond ((and (proto-packed field) (packed-type-p class))
(collect-serializer
(let ((tag (make-tag class index)))
- `(setq ,vidx (serialize-packed ,reader ,class ,tag ,vbuf ,vidx)))))
+ `(setq ,vidx (serialize-packed ,reader ,class ,tag ,vbuf ,vidx
+ ,vectorp)))))
((keywordp class)
(collect-serializer
(let ((tag (make-tag class index)))
(collect-serializer
(let ((tag (make-tag $wire-type-varint index)))
(if (proto-packed field)
- `(setq ,vidx (serialize-packed-enum ,reader '(,@(proto-values msg)) ,tag ,vbuf ,vidx))
+ `(setq ,vidx (serialize-packed-enum ,reader '(,@(proto-values msg)) ,tag ,vbuf ,vidx
+ ,vectorp))
`(,iterator (,vval ,reader)
(setq ,vidx (serialize-enum ,vval '(,@(proto-values msg)) ,tag ,vbuf ,vidx)))))))
(index (proto-index field)))
(when reader
(cond ((eq (proto-required field) :repeated)
- (let ((iterator (if (vector-field-p field) 'dovector 'dolist)))
+ (let* ((vectorp (vector-field-p field))
+ (iterator (if vectorp 'dovector 'dolist)))
(cond ((and (proto-packed field) (packed-type-p class))
(collect-sizer
(let ((tag (make-tag class index)))
- `(iincf ,vsize (packed-size ,reader ,class ,tag)))))
+ `(iincf ,vsize (packed-size ,reader ,class ,tag ,vectorp)))))
((keywordp class)
(collect-sizer
(let ((tag (make-tag class index)))
(when (or slot reader)
(cond ((eq (proto-required field) :repeated)
(cond ((keywordp type)
- (map () #'(lambda (v)
- (print-prim v type field stream
- (or suppress-line-breaks indent)))
- (read-slot object slot reader)))
+ (doseq (v (read-slot object slot reader))
+ (print-prim v type field stream
+ (or suppress-line-breaks indent))))
((typep (setq msg (and type (or (find-message trace type)
(find-enum trace type)
(find-type-alias trace type))))
(if suppress-line-breaks
(format stream "~A { " (proto-name field))
(format stream "~&~VT~A {~%" indent (proto-name field)))
- (map () (curry #'do-field v msg indent)
- (proto-fields msg))
+ (dolist (f (proto-fields msg))
+ (do-field v msg indent f))
(if suppress-line-breaks
(format stream "} ")
(format stream "~&~VT}~%" indent)))))))
((typep msg 'protobuf-enum)
- (map () #'(lambda (v)
- (print-enum v msg field stream
- (or suppress-line-breaks indent)))
- (read-slot object slot reader)))
+ (doseq (v (read-slot object slot reader))
+ (print-enum v msg field stream
+ (or suppress-line-breaks indent))))
((typep msg 'protobuf-type-alias)
(let ((type (proto-proto-type msg)))
- (map () #'(lambda (v)
- (let ((v (funcall (proto-serializer msg) v)))
- (print-prim v type field stream
- (or suppress-line-breaks indent))))
- (read-slot object slot reader))))))
+ (doseq (v (read-slot object slot reader))
+ (let ((v (funcall (proto-serializer msg) v)))
+ (print-prim v type field stream
+ (or suppress-line-breaks indent))))))))
(t
(cond ((eq type :bool)
(let ((v (cond ((or (eq (proto-required field) :required)
(if suppress-line-breaks
(format stream "~A { " (proto-name field))
(format stream "~&~VT~A {~%" indent (proto-name field)))
- (map () (curry #'do-field v msg indent)
- (proto-fields msg))
+ (dolist (f (proto-fields msg))
+ (do-field v msg indent f))
(if suppress-line-breaks
(format stream "} ")
(format stream "~&~VT}~%" indent))))))
(format stream "~A { " (proto-name message))
(format stream "~&~A {~%" (proto-name message)))
(format stream "{"))
- (map () (curry #'do-field object message 0) (proto-fields message))
+ (dolist (f (proto-fields message))
+ (do-field object message 0 f))
(if suppress-line-breaks
(format stream "}")
(format stream "~&}~%"))
;; (camel-case "camel-case") => "CamelCase"
(defun camel-case (string &optional (separators '(#\-)))
+ "Take a hyphen-separated string and turn it into a camel-case string."
(let ((words (split-string string :separators separators)))
(format nil "~{~@(~A~)~}" words)))
;; (camel-case-but-one "camel-case") => "camelCase"
(defun camel-case-but-one (string &optional (separators '(#\-)))
+ "Take a hyphen-separated string and turn its tail into a camel-case string."
(let ((words (split-string string :separators separators)))
(format nil "~(~A~)~{~@(~A~)~}" (car words) (cdr words))))
;; (uncamel-case "RPC_LispServiceRequest_get_request") => "RPC-LISP-SERVICE-REQUEST-GET-REQUEST"
;; (uncamel-case "TCP2Name3") => "TCP2-NAME3"
(defun uncamel-case (name)
+ "Take a camel-case string and turn it into a hyphen-separated string."
;; We need a whole state machine to get this right
(labels ((uncamel (chars state result)
(let ((ch (first chars)))
;;; Collectors, etc
(defmacro with-collectors ((&rest collection-descriptions) &body body)
+ "'collection-descriptions' is a list of clauses of the form (coll function).
+ The body can call each 'function' to add a value to 'coll'. 'function'
+ runs in constant time, regardless of the length of the list."
(let ((let-bindings ())
(flet-bindings ())
(dynamic-extents ())
,@body))
(defmacro dovector ((var vector &optional value) &body body)
+ "Like 'dolist', but iterates over the vector 'vector'."
(with-gensyms (vidx vlen vvec)
`(let* ((,vvec ,vector)
(,vlen (length ,vvec)))
do (progn ,@body)
finally (return ,value)))))
+(defmacro doseq ((var sequence &optional value) &body body)
+ "Iterates over a sequence, using 'dolist' or 'dovector' depending on
+ the type of the sequence. In optimized code, this turns out to be
+ faster than (map () #'f sequence).
+ Note that the body gets expanded twice!"
+ (with-gensyms (vseq)
+ `(let ((,vseq ,sequence))
+ (if (vectorp ,vseq)
+ (dovector (,var ,vseq ,value)
+ ,@body)
+ (dolist (,var ,vseq ,value)
+ ,@body)))))
+
;;; Functional programming, please
(defun curry (function &rest args)
+ "Returns a function that applies 'function' to 'args', plus any
+ additional arguments given at the call site."
(if (and args (null (cdr args))) ;fast test for length = 1
(let ((arg (car args)))
#'(lambda (&rest more-args)
`(encode-double ,val ,buffer idx)))))
form))
-(defun serialize-packed (values type tag buffer index)
+(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 (type (simple-array (unsigned-byte 8)) buffer)
+ (declare (ignore vectorp)
+ (type (simple-array (unsigned-byte 8)) buffer)
(type (unsigned-byte 32) tag)
(type fixnum index))
(locally (declare #.$optimize-serialization)
(map () #'(lambda (val) (setq idx (encode-double val buffer idx))) values)))
idx)))
-(define-compiler-macro serialize-packed (&whole form values type tag buffer index)
+;; The optimized serializers supply 'vectorp' so we can generate better code
+(define-compiler-macro serialize-packed (&whole form values type tag buffer index
+ &optional (vectorp nil vectorp-p))
(setq type (fold-symbol type)
tag (fold-symbol tag))
- (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
- :fixed32 :sfixed32 :fixed64 :sfixed64
- :bool :float :double))
+ (if (and vectorp-p
+ `(member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
+ :fixed32 :sfixed32 :fixed64 :sfixed64
+ :bool :float :double)))
`(locally (declare #.$optimize-serialization
(type (simple-array (unsigned-byte 8)) ,buffer)
;; 'tag' is a constant, no need to declare its type
(packed-size ,values ,type ,tag)
(declare (type fixnum len) (ignore full-len))
(setq idx (encode-uint32 len ,buffer idx)))
- (map () #'(lambda (val)
- ,(ecase type
- ((:int32)
- `(setq idx (encode-uint32 (ldb (byte 32 0) val) ,buffer idx)))
- ((:int64)
- `(setq idx (encode-uint64 (ldb (byte 64 0) val) ,buffer idx)))
- ((:uint32)
- `(setq idx (encode-uint32 val ,buffer idx)))
- ((:uint64)
- `(setq idx (encode-uint64 val ,buffer idx)))
- ((:sint32)
- `(setq idx (encode-uint32 (zig-zag-encode32 val) ,buffer idx)))
- ((:sint64)
- `(setq idx (encode-uint64 (zig-zag-encode64 val) ,buffer idx)))
- ((:fixed32)
- `(setq idx (encode-fixed32 val ,buffer idx)))
- ((:sfixed32)
- `(setq idx (encode-sfixed32 val ,buffer idx)))
- ((:fixed64)
- `(setq idx (encode-fixed64 val ,buffer idx)))
- ((:sfixed64)
- `(setq idx (encode-sfixed64 val ,buffer idx)))
- ((:bool)
- `(setq idx (encode-uint32 (if val 1 0) ,buffer idx)))
- ((:float)
- `(setq idx (encode-single val ,buffer idx)))
- ((:double)
- `(setq idx (encode-double val ,buffer idx))))) ,values)
+ (,(if vectorp 'dovector 'dolist) (val ,values)
+ ,(ecase type
+ ((:int32)
+ `(setq idx (encode-uint32 (ldb (byte 32 0) val) ,buffer idx)))
+ ((:int64)
+ `(setq idx (encode-uint64 (ldb (byte 64 0) val) ,buffer idx)))
+ ((:uint32)
+ `(setq idx (encode-uint32 val ,buffer idx)))
+ ((:uint64)
+ `(setq idx (encode-uint64 val ,buffer idx)))
+ ((:sint32)
+ `(setq idx (encode-uint32 (zig-zag-encode32 val) ,buffer idx)))
+ ((:sint64)
+ `(setq idx (encode-uint64 (zig-zag-encode64 val) ,buffer idx)))
+ ((:fixed32)
+ `(setq idx (encode-fixed32 val ,buffer idx)))
+ ((:sfixed32)
+ `(setq idx (encode-sfixed32 val ,buffer idx)))
+ ((:fixed64)
+ `(setq idx (encode-fixed64 val ,buffer idx)))
+ ((:sfixed64)
+ `(setq idx (encode-sfixed64 val ,buffer idx)))
+ ((:bool)
+ `(setq idx (encode-uint32 (if val 1 0) ,buffer idx)))
+ ((:float)
+ `(setq idx (encode-single val ,buffer idx)))
+ ((:double)
+ `(setq idx (encode-double val ,buffer idx)))))
idx))
form))
`(i+ (length32 ,tag) 8))))
form))
-(defun packed-size (values type tag)
+(defun packed-size (values type tag &optional vectorp)
"Returns the size in bytes that the packed object will take when serialized.
Watch out, this function turns off most type checking."
- (declare (type (unsigned-byte 32) tag))
+ (declare (ignore vectorp)
+ (type (unsigned-byte 32) tag))
(locally (declare #.$optimize-serialization)
(let ((len (let ((len 0))
(declare (type fixnum len))
;; of just the payload
(values (i+ (length32 tag) (length32 len) len) len))))
-(define-compiler-macro packed-size (&whole form values type tag)
+;; The optimized serializers supply 'vectorp' so we can generate better code
+(define-compiler-macro packed-size (&whole form values type tag
+ &optional (vectorp nil vectorp-p))
(setq type (fold-symbol type)
tag (fold-symbol tag))
- (if (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
- :fixed32 :sfixed32 :fixed64 :sfixed64
- :bool :float :double))
+ (if (and vectorp-p
+ (member type '(:int32 :uint32 :int64 :uint64 :sint32 :sint64
+ :fixed32 :sfixed32 :fixed64 :sfixed64
+ :bool :float :double)))
`(locally (declare #.$optimize-serialization)
(let ((len (let ((len 0))
(declare (type fixnum len))
- (map () #'(lambda (val)
- (iincf len ,(ecase type
- ((:int32) `(length32 (ldb (byte 32 0) val)))
- ((:int64) `(length64 (ldb (byte 64 0) val)))
- ((:uint32) `(length32 val))
- ((:uint64) `(length64 val))
- ((:sint32) `(length32 (zig-zag-encode32 val)))
- ((:sint64) `(length64 (zig-zag-encode64 val)))
- ((:fixed32 :sfixed32) `4)
- ((:fixed64 :sfixed64) `8)
- ((:bool) `1)
- ((:float) `4)
- ((:double) `8)))) ,values)
+ (,(if vectorp 'dovector 'dolist) (val ,values)
+ (iincf len ,(ecase type
+ ((:int32) `(length32 (ldb (byte 32 0) val)))
+ ((:int64) `(length64 (ldb (byte 64 0) val)))
+ ((:uint32) `(length32 val))
+ ((:uint64) `(length64 val))
+ ((:sint32) `(length32 (zig-zag-encode32 val)))
+ ((:sint64) `(length64 (zig-zag-encode64 val)))
+ ((:fixed32 :sfixed32) `4)
+ ((:fixed64 :sfixed64) `8)
+ ((:bool) `1)
+ ((:float) `4)
+ ((:double) `8))))
len)))
(declare (type (unsigned-byte 32) len))
(values (i+ (length32 (the (unsigned-byte 32) ,tag)) (length32 len) len) len)))
projects / cl-protobufs.git / commitdiff