--- /dev/null
+*.lx64fsl
+*.lx32fsl
+*.fasl
(defun clos-type-to-protobuf-type (type &optional type-filter enum-filter)
"Given a Lisp type, returns a Protobuf type, a class or primitive type,
whether or not to pack the field, and (optionally) a set of enum values."
- (let ((type (if type-filter (funcall type-filter type) type))
- (list-of-list-of (list-of-list-of)))
- (flet ()
- (if (listp type)
+ (let* ((type (if type-filter (funcall type-filter type) type))
+ (list-of-list-of (list-of-list-of))
+ (type-enum (when (and *protobuf* (symbolp type))
+ (find-enum *protobuf* type)))
+ (type-alias (when (and *protobuf* (symbolp type))
+ (find-type-alias *protobuf* type)))
+ (expanded-type (type-expand type)))
+ (cond
+ ((listp type)
(destructuring-bind (head &rest tail) type
(case head
((or)
(multiple-value-bind (type class)
(lisp-type-to-protobuf-type (first tail))
(values type class (packed-type-p class)))
- (lisp-type-to-protobuf-type type)))))
- (lisp-type-to-protobuf-type type)))))
+ (lisp-type-to-protobuf-type type))))))
+ (type-alias
+ (values (proto-proto-type-str type-alias) type))
+ ((not (or type-enum (equal type expanded-type)))
+ (clos-type-to-protobuf-type expanded-type))
+ (t
+ (lisp-type-to-protobuf-type type)))))
(defun lisp-type-to-protobuf-type (type)
(case type
;; Only now can we bind *protobuf* to the new message
(*protobuf* message))
(with-collectors ((slots collect-slot)
- (forms collect-form))
+ (forms collect-form)
+ ;; The typedef needs to be first in forms otherwise ccl warns.
+ ;; We'll collect them separately and splice them in first.
+ (type-forms collect-type-form))
(dolist (field fields)
(case (car field)
((define-enum define-message define-extend define-extension define-group
;; If we've got an alias, define a a type that is the subtype of
;; the Lisp class that typep and subtypep work
(unless (or (eq type alias-for) (find-class type nil))
- (collect-form `(deftype ,type () ',alias-for)))
+ (collect-type-form `(deftype ,type () ',alias-for)))
;; If no alias, define the class now
- (collect-form `(defclass ,type () (,@slots)
+ (collect-type-form `(defclass ,type () (,@slots)
,@(and documentation `((:documentation ,documentation))))))
`(progn
define-message
,message
((with-proto-source-location (,type ,name protobuf-message ,@source-location)
+ ,@type-forms
,@forms))))))
(defun conc-name-for-type (type conc-name)
collect (make-instance 'protobuf-option
:name (if (symbolp key) (slot-name->proto key) key)
:value val)))
- (message (find-message *protobuf* name))
+ (message (find-message *protobuf* type))
(conc-name (or (conc-name-for-type type conc-name)
(and message (proto-conc-name message))))
(alias-for (and message (proto-alias-for message)))
:class (proto-class message)
:name (proto-name message)
:qualified-name (proto-qualified-name message)
- :parent (proto-parent message)
+ :parent *protobuf*
:alias-for alias-for
:conc-name conc-name
:enums (copy-list (proto-enums message))
;; Only now can we bind *protobuf* to the (group) message
(*protobuf* message))
(with-collectors ((slots collect-slot)
- (forms collect-form))
+ (forms collect-form)
+ ;; The typedef needs to be first in forms otherwise ccl warns.
+ ;; We'll collect them separately and splice them in first.
+ (type-forms collect-type-form))
(dolist (field fields)
(case (car field)
((define-enum define-message define-extend define-extension define-group
;; If we've got an alias, define a a type that is the subtype of
;; the Lisp class that typep and subtypep work
(unless (or (eq type alias-for) (find-class type nil))
- (collect-form `(deftype ,type () ',alias-for)))
+ (collect-type-form `(deftype ,type () ',alias-for)))
;; If no alias, define the class now
- (collect-form `(defclass ,type () (,@slots)
+ (collect-type-form `(defclass ,type () (,@slots)
,@(and documentation `((:documentation ,documentation))))))
`(progn
define-group
,message
((with-proto-source-location (,type ,name protobuf-message ,@source-location)
+ ,@type-forms
,@forms))
,mfield
,mslot))))
'serializer' is a function that takes a Lisp object and generates a Protobufs object.
'deserializer' is a function that takes a Protobufs object and generates a Lisp object.
If 'alias-for' is given, no Lisp 'deftype' will be defined."
- (let* ((name (or name (class-name->proto type)))
- (proto (multiple-value-bind (typ cl)
- (lisp-type-to-protobuf-type proto-type)
- (declare (ignore typ))
- (assert (keywordp cl) ()
- "The alias ~S must resolve to a Protobufs primitive type"
- type)
- cl))
- (alias (make-instance 'protobuf-type-alias
- :class type
- :name name
- :lisp-type lisp-type
- :proto-type proto
- :serializer serializer
- :deserializer deserializer
- :qualified-name (make-qualified-name *protobuf* name)
- :parent *protobuf*
- :documentation documentation
- :source-location source-location)))
- (with-collectors ((forms collect-form))
- (if alias-for
- ;; If we've got an alias, define a a type that is the subtype of
- ;; the Lisp enum so that typep and subtypep work
- (unless (eq type alias-for)
- (collect-form `(deftype ,type () ',alias-for)))
- ;; If no alias, define the Lisp enum type now
- (collect-form `(deftype ,type () ',lisp-type)))
- `(progn
- define-type-alias
- ,alias
- ((with-proto-source-location (,type ,name protobuf-type-alias ,@source-location)
- ,@forms))))))
+ (multiple-value-bind (type-str proto)
+ (lisp-type-to-protobuf-type proto-type)
+ (assert (keywordp proto) ()
+ "The alias ~S must resolve to a Protobufs primitive type"
+ type)
+ (let* ((name (or name (class-name->proto type)))
+ (alias (make-instance 'protobuf-type-alias
+ :class type
+ :name name
+ :lisp-type lisp-type
+ :proto-type proto
+ :proto-type-str type-str
+ :serializer serializer
+ :deserializer deserializer
+ :qualified-name (make-qualified-name *protobuf* name)
+ :parent *protobuf*
+ :documentation documentation
+ :source-location source-location)))
+ (with-collectors ((forms collect-form))
+ (if alias-for
+ ;; If we've got an alias, define a a type that is the subtype of
+ ;; the Lisp enum so that typep and subtypep work
+ (unless (eq type alias-for)
+ (collect-form `(deftype ,type () ',alias-for)))
+ ;; If no alias, define the Lisp enum type now
+ (collect-form `(deftype ,type () ',lisp-type)))
+ `(progn
+ define-type-alias
+ ,alias
+ ((with-proto-source-location (,type ,name protobuf-type-alias ,@source-location)
+ ,@forms)))))))
\f
;;; Ensure everything in a Protobufs schema is defined
:initarg :lisp-type)
(proto-type :reader proto-proto-type ;a .proto type specifier
:initarg :proto-type)
+ (proto-type-str :reader proto-proto-type-str
+ :initarg :proto-type-str)
(serializer :reader proto-serializer ;Lisp -> Protobufs conversion function
:initarg :serializer)
(deserializer :reader proto-deserializer ;Protobufs -> Lisp conversion function
:class (proto-class message)
:name (proto-name message)
:qualified-name (proto-qualified-name message)
- :parent (proto-parent message)
+ :parent protobuf
:alias-for (proto-alias-for message)
:conc-name (proto-conc-name message)
:enums (copy-list (proto-enums message))
(:protobuf-file "forward_reference")
(:file "lisp-reference-tests")))
+ (module "nested-extend-test"
+ :serial t
+ :pathname #p""
+ :components
+ ((:protobuf-file "extend-test")
+ (:file "lisp-extend-test")))
+
;; Google's own protocol buffers and protobuf definitions tests
#+++notyet
(:module "google-tests-proto"
--- /dev/null
+// Free Software published under an MIT-like license. See LICENSE
+//
+// Copyright (c) 2012 Google, Inc. All rights reserved.
+//
+// Original author: Alejandro Sedeño
+
+syntax = "proto2";
+
+package protobuf_extend_base_unittest;
+
+message Foo {
+ extensions 100 to 199;
+}
+
+message Bar {
+}
+
+message Baz {
+ extensions 300 to 399;
+}
--- /dev/null
+// Free Software published under an MIT-like license. See LICENSE
+//
+// Copyright (c) 2012 Google, Inc. All rights reserved.
+//
+// Original author: Alejandro Sedeño
+
+syntax = "proto2";
+
+import "extend-test-base.proto";
+
+package protobuf_extend_unittest;
+
+message Foo {
+ extensions 200 to 299;
+}
+
+message Bar {
+ // Extend file-local Foo with this Bar.
+ extend Foo {
+ optional Bar foo_227 = 227;
+ }
+ // Extend file-local Foo with imported Bar.
+ extend Foo {
+ optional protobuf_extend_base_unittest.Bar foo_228 = 228;
+ }
+ // Extend imported Foo with this Bar.
+ extend protobuf_extend_base_unittest.Foo {
+ optional Bar foo_127 = 127;
+ }
+ // Extend imported Foo with imported Bar.
+ extend protobuf_extend_base_unittest.Foo {
+ optional protobuf_extend_base_unittest.Bar foo_128 = 128;
+ }
+}
+
+// NB: Unlike Foo and Bar, no Quux is defined in our import.
+// Unlike Foo and Bar, no Baz is defined in this proto file.
+message Quux {
+ // Extend imported Baz with self.
+ extend protobuf_extend_base_unittest.Baz {
+ optional Quux ext = 327;
+ }
+}
--- /dev/null
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; ;;;
+;;; Free Software published under an MIT-like license. See LICENSE ;;;
+;;; ;;;
+;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;;
+;;; ;;;
+;;; Original author: Alejandro Sedeño ;;;
+;;; ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(in-package "PROTO-TEST")
+
+(define-test extend-test ()
+ (let* ((schema (proto:find-schema "ExtendTest"))
+ (imported-schema (proto:find-schema "ExtendTestBase"))
+ (foo (proto:find-message schema "Foo"))
+ (bar (proto:find-message schema "Bar"))
+ (quux (proto:find-message schema "Quux"))
+ (ifoo (proto:find-message imported-schema "Foo"))
+ (ibar (proto:find-message imported-schema "Bar"))
+ (ibaz (proto:find-message imported-schema "Baz")))
+ (destructuring-bind (local-local local-import import-local import-import)
+ (proto-impl:proto-extenders bar)
+ ;; Are we extending the right message?
+ (assert-equal (proto-impl:proto-class local-local)
+ (proto-impl:proto-class foo))
+ (assert-equal (proto-impl:proto-class local-import)
+ (proto-impl:proto-class foo))
+ (assert-equal (proto-impl:proto-class import-local)
+ (proto-impl:proto-class ifoo))
+ (assert-equal (proto-impl:proto-class import-import)
+ (proto-impl:proto-class ifoo))
+ ;; Is the extended field of the right type?
+ (assert-equal (proto-impl:proto-class
+ (first (proto-impl:proto-extended-fields local-local)))
+ (proto-impl:proto-class bar))
+ (assert-equal (proto-impl:proto-class
+ (first (proto-impl:proto-extended-fields local-import)))
+ (proto-impl:proto-class ibar))
+ (assert-equal (proto-impl:proto-class
+ (first (proto-impl:proto-extended-fields import-local)))
+ (proto-impl:proto-class bar))
+ (assert-equal (proto-impl:proto-class
+ (first (proto-impl:proto-extended-fields import-import)))
+ (proto-impl:proto-class ibar)))
+ ;; Smaller stand-alone test
+ (let ((ebaz (first (proto-extenders quux))))
+ (assert-equal (proto-impl:proto-class ebaz) (proto-impl:proto-class ibaz))
+ (assert-equal (proto-impl:proto-class (first (proto-extended-fields ebaz)))
+ (proto-impl:proto-class quux)))))
+
+(register-test 'extend-test)
(format t "~&Running test ~A" test)
(funcall test)))
-(defmacro assert-equal (actual expected &key (test 'equal))
- `(unless (,test ,actual ,expected)
+(defmacro assert-equal (actual expected &key (test '#'equal))
+ `(unless (funcall ,test ,actual ,expected)
(warn "The value of ~S (~S) is not equal to the expected value ~S"
',actual ,actual ,expected)))
(eval-when (:compile-toplevel :load-toplevel :execute)
+(deftype user-integer () 'integer)
+
(defclass basic-test1 ()
((intval :type (signed-byte 32)
:initarg :intval)))
:initform ()
:initarg :recvals)))
+(defclass basic-test7 ()
+ ((intval :type (or null user-integer)
+ :initform ()
+ :initarg :intval)))
+
) ;eval-when
(defvar *basic-test-schema*
(generate-schema-for-classes
- '(basic-test1 basic-test2 basic-test3 basic-test4 basic-test5 basic-test6)
+ '(basic-test1 basic-test2 basic-test3 basic-test4 basic-test5 basic-test6 basic-test7)
:install t))
(define-test basic-serialization ()
(test5 (make-instance 'basic-test5
:color :red :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven")))
(test6 (make-instance 'basic-test6
- :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven") :recvals (list test2 test2b))))
+ :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven") :recvals (list test2 test2b)))
+ (test7 (make-instance 'basic-test7 :intval 150))
+)
(let ((tser1 (serialize-object-to-bytes test1 'basic-test1))
(tser1b (serialize-object-to-bytes test1b 'basic-test1))
(tser2 (serialize-object-to-bytes test2 'basic-test2))
(tser3 (serialize-object-to-bytes test3 'basic-test3))
(tser4 (serialize-object-to-bytes test4 'basic-test4))
(tser5 (serialize-object-to-bytes test5 'basic-test5))
- (tser6 (serialize-object-to-bytes test6 'basic-test6)))
+ (tser6 (serialize-object-to-bytes test6 'basic-test6))
+ (tser7 (serialize-object-to-bytes test7 'basic-test7)))
(assert-true (equalp tser1 #(#x08 #x96 #x01)))
(assert-true (equalp tser1b #(#x08 #xEA #xFE #xFF #xFF #x0F)))
(assert-true (equalp tser2 #(#x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67)))
#x10 #x04 #x02 #x03 #x05 #x07
#x1A #x03 #x74 #x77 #x6F #x1A #x05 #x74 #x68 #x72 #x65 #x65 #x1A #x04 #x66 #x69 #x76 #x65 #x1A #x05 #x73 #x65 #x76 #x65 #x6E)))
(assert-true (equalp tser6 #(#x08 #x04 #x02 #x03 #x05 #x07 #x12 #x03 #x74 #x77 #x6F #x12 #x05 #x74 #x68 #x72 #x65 #x65 #x12 #x04 #x66 #x69 #x76 #x65 #x12 #x05 #x73 #x65 #x76 #x65 #x6E #x1A #x09 #x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67 #x1A #x07 #x12 #x05 #x31 #x20 #x32 #x20 #x33)))
+ (assert-true (equalp tser7 #(#x08 #x96 #x01)))
(macrolet ((slots-equalp (obj1 obj2 &rest slots)
(proto-impl::with-gensyms (vobj1 vobj2)
(proto-impl::with-collectors ((forms collect-form))
strval)
(slots-equalp (second (slot-value test6 'recvals))
(second (slot-value (deserialize-object 'basic-test6 tser6) 'recvals))
- strval)))))
+ strval)
+ (slots-equalp test7 (deserialize-object 'basic-test7 tser7)
+ intval)))))
(define-test basic-optimized-serialization ()
(dolist (class '(basic-test1 basic-test2 basic-test3 basic-test4 basic-test5 basic-test6))
(let ((message (find-message *basic-test-schema* class)))
- (eval (generate-object-size message))
- (eval (generate-serializer message))
- (eval (generate-deserializer message))))
+ (handler-bind ((style-warning #'muffle-warning))
+ (eval (generate-object-size message))
+ (eval (generate-serializer message))
+ (eval (generate-deserializer message)))))
(let* ((test1 (make-instance 'basic-test1 :intval 150))
(test1b (make-instance 'basic-test1 :intval -150))
(test2 (make-instance 'basic-test2 :strval "testing"))
(test5 (make-instance 'basic-test5
:color :red :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven")))
(test6 (make-instance 'basic-test6
- :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven") :recvals (list test2 test2b))))
+ :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven") :recvals (list test2 test2b)))
+ (test7 (make-instance 'basic-test7 :intval 150)))
(let ((tser1 (serialize-object-to-bytes test1 'basic-test1))
(tser1b (serialize-object-to-bytes test1b 'basic-test1))
(tser2 (serialize-object-to-bytes test2 'basic-test2))
(tser3 (serialize-object-to-bytes test3 'basic-test3))
(tser4 (serialize-object-to-bytes test4 'basic-test4))
(tser5 (serialize-object-to-bytes test5 'basic-test5))
- (tser6 (serialize-object-to-bytes test6 'basic-test6)))
+ (tser6 (serialize-object-to-bytes test6 'basic-test6))
+ (tser7 (serialize-object-to-bytes test7 'basic-test7)))
(assert-true (equalp tser1 #(#x08 #x96 #x01)))
(assert-true (equalp tser1b #(#x08 #xEA #xFE #xFF #xFF #x0F)))
(assert-true (equalp tser2 #(#x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67)))
#x10 #x04 #x02 #x03 #x05 #x07
#x1A #x03 #x74 #x77 #x6F #x1A #x05 #x74 #x68 #x72 #x65 #x65 #x1A #x04 #x66 #x69 #x76 #x65 #x1A #x05 #x73 #x65 #x76 #x65 #x6E)))
(assert-true (equalp tser6 #(#x08 #x04 #x02 #x03 #x05 #x07 #x12 #x03 #x74 #x77 #x6F #x12 #x05 #x74 #x68 #x72 #x65 #x65 #x12 #x04 #x66 #x69 #x76 #x65 #x12 #x05 #x73 #x65 #x76 #x65 #x6E #x1A #x09 #x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67 #x1A #x07 #x12 #x05 #x31 #x20 #x32 #x20 #x33)))
+ (assert-true (equalp tser7 #(#x08 #x96 #x01)))
(macrolet ((slots-equalp (obj1 obj2 &rest slots)
(proto-impl::with-gensyms (vobj1 vobj2)
(proto-impl::with-collectors ((forms collect-form))
strval)
(slots-equalp (second (slot-value test6 'recvals))
(second (slot-value (deserialize-object 'basic-test6 tser6) 'recvals))
- strval)))))
+ strval)
+ (slots-equalp test7 (deserialize-object 'basic-test7 tser7)
+ intval)))))
(define-test text-serialization ()
(let* ((test1 (make-instance 'basic-test1 :intval 150))
(test5 (make-instance 'basic-test5
:color :red :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven")))
(test6 (make-instance 'basic-test6
- :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven") :recvals (list test2 test2b))))
+ :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven") :recvals (list test2 test2b)))
+ (test7 (make-instance 'basic-test7 :intval 150)))
(let ((tser1 (serialize-object-to-bytes test1 'basic-test1))
(tser1b (serialize-object-to-bytes test1b 'basic-test1))
(tser2 (serialize-object-to-bytes test2 'basic-test2))
(tser3 (serialize-object-to-bytes test3 'basic-test3))
(tser4 (serialize-object-to-bytes test4 'basic-test4))
(tser5 (serialize-object-to-bytes test5 'basic-test5))
- (tser6 (serialize-object-to-bytes test6 'basic-test6)))
+ (tser6 (serialize-object-to-bytes test6 'basic-test6))
+ (tser7 (serialize-object-to-bytes test7 'basic-test7)))
(macrolet ((slots-equalp (obj1 obj2 &rest slots)
(proto-impl::with-gensyms (vobj1 vobj2)
(proto-impl::with-collectors ((forms collect-form))
(second (slot-value
(with-input-from-string (s text)
(parse-text-format 'basic-test6 :stream s)) 'recvals))
- strval))))))
+ strval))
+ (let ((text (with-output-to-string (s)
+ (print-text-format test7 'basic-test7 :stream s))))
+ (assert-true (string= text (with-output-to-string (s)
+ (print-text-format
+ (deserialize-object 'basic-test7 tser7) 'basic-test7 :stream s))))
+ (slots-equalp test7 (with-input-from-string (s text)
+ (parse-text-format 'basic-test7 :stream s))
+ intval))))))
(proto:define-schema integrity-test
(proto:deserialize-object 'add-color2 ser2) nil :stream s)))))))
+;; Type aliases
+(proto:define-schema type-alias-test
+ (:package proto_test)
+ (proto:define-type-alias lisp-integer-as-string ()
+ :lisp-type integer
+ :proto-type string
+ :serializer princ-to-string
+ :deserializer parse-integer)
+ (proto:define-message type-alias-test-message ()
+ (test-field :type (or null lisp-integer-as-string))))
+
+(define-test type-aliases ()
+ (assert-equal
+ (proto-impl:proto-type
+ (first (proto-impl:proto-fields
+ (proto:find-message (proto:find-schema 'type-alias-test)
+ 'proto-test::type-alias-test-message))))
+ "string")
+ (let* ((msg1 (make-instance 'type-alias-test-message :test-field 5))
+ (ser1 (proto:serialize-object-to-bytes msg1 'type-alias-test-message))
+ (dser1 (deserialize-object 'type-alias-test-message ser1)))
+ (assert-equal ser1 #(10 1 53) :test #'equalp)
+ (assert-equal (slot-value msg1 'test-field)
+ (slot-value dser1 'test-field))))
+
(define-test-suite serialization-tests ()
(basic-serialization
basic-optimized-serialization
#+qres geodata-serialization
#+qres geodata-optimized-serialization
extension-serialization
- group-serialization))
+ group-serialization
+ type-aliases))
(register-test 'serialization-tests)
(deftype sfixed32 () '(signed-byte 32))
(deftype sfixed64 () '(signed-byte 64))
+;; Type expansion
+(defun type-expand (type)
+ #+allegro (excl:normalize-type type :default type)
+ #+ccl (ccl::type-expand type)
+ #+clisp (ext:type-expand type)
+ #+cmu (kernel:type-expand type)
+ #+lispworks (type:expand-user-type type)
+ #+sbcl (sb-ext:typexpand type)
+ #-(or allegro ccl clisp cmu lispworks sbcl) type)
;;; Code generation utilities
projects / cl-protobufs.git / commitdiff