Now that Protobufs has a test suite, it found a few things to fix.

 - Don't generate warnings for anonymous enums, they're harmless
   and ubiquitous.
 - 'member' types where are all the members are keywords, is a symbol,
   which got converted to a Protobufs 'string'. Wrong.
 - If a field has an enum type, the (Lisp) default value should be
   treated as a keyword.
 - When parsing a .proto file or using the 'define-xxx' macros, any
   options that are handled specially should be trimmed from the
   options list so that they don't get printed twice.
 - Add 'remove-options' for the above.
 - Make the options printer be more type-aware.
 - Clean up examples.lisp
 - 'schemas-equal' can ignore the schema name/class if they're null.

Passes 'precheckin'. Even with the new unit tests in place.

git-svn-id: http://svn.internal.itasoftware.com/svn/ita/trunk/qres/lisp/quux/protobufs@544737 f8382938-511b-0410-9cdd-bb47b084005c

diff --git a/asdf-support.lisp b/asdf-support.lisp
index 785e673fda66bd02c11e4e918ca3653828639640..095d58396f827eb4462a46e1e26573b6a119f52d 100644 (file)
--- a/asdf-support.lisp
+++ b/asdf-support.lisp
@@ -13,8 +13,8 @@
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 
-(defclass proto-file (asdf:cl-source-file)
-  ((asdf::type :initform "proto"))
+(defclass protobuf-file (asdf:cl-source-file)
+  ((asdf::type :initform "protobuf"))
   (:documentation
    "This ASDF component defines COMPILE-OP and LOAD-OP operations
     that compiles the .proto file into a .lisp file, and the compiles
@@ -22,29 +22,29 @@
 
 )       ;eval-when
 
-(defmethod asdf:output-files ((op asdf:compile-op) (c proto-file))
+(defmethod asdf:output-files ((op asdf:compile-op) (c protobuf-file))
   (append (call-next-method)
           (make-pathname :type "lisp" :defaults (asdf:component-pathname c))))
 
-(defmethod asdf:perform ((op asdf:compile-op) (c proto-file))
+(defmethod asdf:perform ((op asdf:compile-op) (c protobuf-file))
   (destructuring-bind (fasl-file lisp-file)
       (asdf:output-files op c)
     (funcall asdf::*compile-op-compile-file-function*
              (parse-protobuf-file (asdf:component-pathname c) lisp-file)
              :output-file fasl-file)))
 
-(defmethod asdf:perform ((op asdf:load-source-op) (c proto-file))
+(defmethod asdf:perform ((op asdf:load-source-op) (c protobuf-file))
   (destructuring-bind (fasl-file lisp-file)
       (asdf:output-files op c)
     (declare (ignore fasl-file))
     (load (parse-protobuf-file (asdf:component-pathname c) lisp-file))))
 
-(defun parse-protobuf-file (proto-file lisp-file)
-  (let ((protobuf (parse-schema-from-file proto-file)))
+(defun parse-protobuf-file (protobuf-file lisp-file)
+  (let ((schema (parse-schema-from-file protobuf-file)))
     (with-open-file (stream lisp-file
                      :direction :output
                      :if-exists :supersede)
-      (write-schema protobuf :stream stream :type :lisp)))
+      (write-schema schema :stream stream :type :lisp)))
   lisp-file)
 
 

diff --git a/clos-transform.lisp b/clos-transform.lisp
index 1239e2b9e8504a34e4b33d55f6dcf3bc6f9143cb..0e0512b4720ca6efad54b79ade4eedda8908f287 100644 (file)
--- a/clos-transform.lisp
+++ b/clos-transform.lisp
@@ -138,6 +138,7 @@
                                         (every #'(lambda (name) (starts-with name prefix)) names))
                                (setq names (mapcar #'(lambda (name) (subseq name (length prefix))) names)))
                              (unless (and unexpanded-type (symbolp unexpanded-type))
+                               #+ignore         ;this happens constantly, the warning is not useful
                                (protobufs-warn "Use DEFTYPE to define a MEMBER type instead of directly using ~S"
                                                expanded-type))
                              (make-instance 'protobuf-enum
@@ -225,7 +226,8 @@
                 (values "string" :symbol))
                (otherwise
                 (cond ((ignore-errors
-                        (subtypep type '(or string character symbol)))
+                        (or (eql type 'symbol)
+                            (subtypep type '(or string character))))
                        (values "string" :string))
                       ((ignore-errors
                         (subtypep type 'byte-vector))
@@ -238,7 +240,7 @@
             ((or)
              (when (or (> (length tail) 2)
                        (not (member 'null tail)))
-               (protobufs-warn "The OR type ~S is too complicated" type))
+               (protobufs-warn "The OR type ~S is too complicated, proceeding anyway" type))
              (if (eq (first tail) 'null)
                (clos-type-to-protobuf-type (second tail))
                (clos-type-to-protobuf-type (first tail))))
@@ -258,7 +260,7 @@
                    (t
                     (let ((new-tail (remove-if #'(lambda (x) (and (listp x) (eq (car x) 'satisfies))) tail)))
                       (when (> (length new-tail) 1)
-                        (protobufs-warn "The AND type ~S is too complicated" type))
+                        (protobufs-warn "The AND type ~S is too complicated, proceeding anyway" type))
                       (type->protobuf-type (first tail))))))
             ((member)                           ;maybe generate an enum type
              (if (or (equal type '(member t nil))
@@ -363,7 +365,10 @@
          default)
         ((symbolp default)
          (cond ((eq type :bool)
-                (boolean-true-p default))))
+                (boolean-true-p default))
+               ;; If we've got a symbol, it must be to initialize an enum type
+               ;; whose values are represented by keywords in Lisp
+               (t (kintern (symbol-name default)))))
         ((stringp default)
          (cond ((eq type :bool)
                 (boolean-true-p default))

diff --git a/define-proto.lisp b/define-proto.lisp
index 9bad506c2ace3dcd483a7ac849c82ddf8ff95e06..337c445b3b6d13e3a888d87cf401ae008753e84a 100644 (file)
--- a/define-proto.lisp
+++ b/define-proto.lisp
@@ -31,17 +31,19 @@
   (let* ((name     (or name (class-name->proto type)))
          (package  (and package (if (stringp package) package (string-downcase (string package)))))
          (lisp-pkg (and lisp-package (if (stringp lisp-package) lisp-package (string lisp-package))))
-         (options  (loop for (key val) on options by #'cddr
-                         collect (make-instance 'protobuf-option
-                                   :name  (if (symbolp key) (slot-name->proto key) key)
-                                   :value val)))
+         (options  (remove-options
+                     (loop for (key val) on options by #'cddr
+                           collect (make-instance 'protobuf-option
+                                     :name  (if (symbolp key) (slot-name->proto key) key)
+                                     :value val))
+                     "optimize_for" "lisp_package"))
          (imports  (if (listp import) import (list import)))
          (schema   (make-instance 'protobuf-schema
                      :class    type
                      :name     name
                      :syntax   (or syntax "proto2")
                      :package  package
-                     :lisp-package (or lisp-pkg package)
+                     :lisp-package (or lisp-pkg (substitute #\- #\_ package))
                      :imports  imports
                      :options  (if optimize
                                  (append options (list (make-instance 'protobuf-option
@@ -191,7 +193,7 @@
                     :parent *protobuf*
                     :alias-for alias-for
                     :conc-name (and conc-name (string conc-name))
-                    :options  options
+                    :options   (remove-options options "default" "packed")
                     :documentation documentation))
          (index 0)
          (*protobuf* message))
@@ -283,12 +285,13 @@
                          :class  type
                          :name   name
                          :parent (proto-parent message)
-                         :conc-name conc-name
                          :alias-for alias-for
+                         :conc-name conc-name
                          :enums    (copy-list (proto-enums message))
                          :messages (copy-list (proto-messages message))
                          :fields   (copy-list (proto-fields message))
-                         :options  (or options (copy-list (proto-options message)))
+                         :options  (remove-options
+                                     (or options (copy-list (proto-options message))) "default" "packed")
                          :extensions (copy-list (proto-extensions message))
                          :message-type :extends         ;this message is an extension
                          :documentation documentation)))
@@ -445,7 +448,7 @@
    'writer' is a Lisp slot writer function to use to set the value."
   (check-type index integer)
   (check-type arity (member :required :optional :repeated))
-  (let* ((slot    (or (and name (proto->slot-name name *protobuf-package*)) type))
+  (let* ((slot    (or type (and name (proto->slot-name name *protobuf-package*))))
          (name    (or name (class-name->proto type)))
          (options (loop for (key val) on options by #'cddr
                         collect (make-instance 'protobuf-option
@@ -476,7 +479,7 @@
                     :name  name
                     :alias-for alias-for
                     :conc-name (and conc-name (string conc-name))
-                    :options  options
+                    :options   (remove-options options "default" "packed")
                     :message-type :group                ;this message is a group
                     :documentation documentation))
          (index 0)
@@ -549,7 +552,7 @@
                      reader))
            (options (append
                      (loop for (key val) on other-options by #'cddr
-                           unless (member key '(:type :reader :writer :name  :default :packed :documentation))
+                           unless (member key '(:type :reader :writer :name :default :packed :documentation))
                              collect (make-instance 'protobuf-option
                                        :name  (slot-name->proto key)
                                        :value val))

diff --git a/examples.lisp b/examples.lisp
index e85d0d9fed20464633065ed3bc73eb5e6002844e..8cdcecf531bd369af4ea966664927c7fcd3bc546 100644 (file)
--- a/examples.lisp
+++ b/examples.lisp
@@ -11,28 +11,10 @@
 (in-package "PROTO-IMPL")
 
 
-;;; Examples, for manual testing
-
-;;--- Turn these into a test suite
-
-#||
-(setq pnr-schema (proto:generate-schema-for-classes
-                  '(qres-core::legacy-pnr
-                    qres-core::legacy-pnr-pax
-                    qres-core::legacy-pnr-segment
-                    qres-core::legacy-pnr-pax-segment)
-                  :slot-filter #'quake::quake-slot-filter
-                  :type-filter #'quake::quake-type-filter
-                  :enum-filter #'quake::quake-enum-filter
-                  :value-filter #'quake::quake-value-filter))
-
-(proto:write-schema pnr-schema)
-(proto:write-schema pnr-schema :type :lisp)
-
-(proto:serialize-object-to-stream pnr 'qres-core::legacy-pnr :stream nil)
-||#
+;;; Some examples; also for some for manual testing
 
 #||
+;; A pretty useful subset of air schedule objects
 (setq sched-schema (proto:generate-schema-for-classes
                     '(quux::zoned-time
                       sched::scheduled-flight
@@ -54,7 +36,9 @@
 (proto:write-schema sched-schema :type :lisp)
 ||#
 
+
 #||
+;; A pretty useful subset of geographic business data
 (defclass geodata ()
   ((countries :type (proto:list-of qres-core::country) :initform () :initarg :countries)
    (regions :type (proto:list-of qres-core::region) :initform () :initarg :regions)
@@ -78,6 +62,7 @@
 (proto:write-schema bizd-schema)
 (proto:write-schema bizd-schema :type :lisp)
 
+;; Load the data
 (let* ((countries (loop for v being the hash-values of (qres-core::country-business-data) collect (car v)))
        (regions   (loop for v being the hash-values of (qres-core::region-business-data) collect v))
        (cities    (loop for v being the hash-values of (qres-core::city-business-data) collect (car v)))
@@ -112,403 +97,9 @@
               'geodata :stream nil))
 ||#
 
-#||
-(setq pschema (proto:generate-schema-for-classes
-               '(proto:protobuf proto:protobuf-option
-                 proto:protobuf-enum proto:protobuf-enum-value
-                 proto:protobuf-message proto:protobuf-field proto:protobuf-extension
-                 proto:protobuf-service proto:protobuf-method)))
-
-(proto:write-schema pschema)
-(proto:write-schema pschema :type :lisp)
-
-(progn (setq pser (proto:serialize-object-to-stream pschema 'proto:protobuf :stream nil)) nil)
-(describe (proto:deserialize-object 'proto:protobuf pser))
-
-(proto:print-text-format pschema)
-(proto:print-text-format (proto:deserialize-object 'proto:protobuf pser))
-
-(dolist (class '(proto:protobuf
-                 proto:protobuf-option
-                 proto:protobuf-enum
-                 proto:protobuf-enum-value
-                 proto:protobuf-message
-                 proto:protobuf-field
-                 proto:protobuf-extension
-                 proto:protobuf-service
-                 proto:protobuf-method))
-  (let ((message (proto-impl:find-message pschema class)))
-    (eval (proto-impl:generate-object-size  message))
-    (eval (proto-impl:generate-serializer   message))
-    (eval (proto-impl:generate-deserializer message))))
-||#
-
-#||
-(defclass proto-test1 ()
-  ((intval :type (integer -2147483648 +2147483647)
-           :initarg :intval)))
-
-(defclass proto-test2 ()
-  ((intval :type (or null (integer -2147483648 +2147483647))
-           :initform nil
-           :initarg :intval)
-   (strval :type (or null string)
-           :initform nil
-           :initarg :strval)))
-
-(defclass proto-test3 ()
-  ((intval :type (or null (integer -2147483648 +2147483647))
-           :initform nil
-           :initarg :intval)
-   (strval :type (or null string)
-           :initform nil
-           :initarg :strval)
-   (recval :type (or null proto-test1)
-           :initform nil
-           :initarg :recval)))
-
-(defclass proto-test4 ()
-  ((intval :type (or null (integer -2147483648 +2147483647))
-           :initform nil
-           :initarg :intval)
-   (strval :type (or null string)
-           :initform nil
-           :initarg :strval)
-   (recval :type (or null proto-test2)
-           :initform nil
-           :initarg :recval)))
-
-(defclass proto-test5 ()
-  ((color   :type (member :red :green :blue)
-            :initarg :color)
-   (intvals :type (proto:list-of integer)
-            :initform ()
-            :initarg :intvals)
-   (strvals :type (proto:list-of string)
-            :initform ()
-            :initarg :strvals)))
-
-(defclass proto-test6 ()
-  ((intvals :type (proto:list-of integer)
-            :initform ()
-            :initarg :intvals)
-   (strvals :type (proto:list-of string)
-            :initform ()
-            :initarg :strvals)
-   (recvals :type (proto:list-of proto-test2)
-            :initform ()
-            :initarg :recvals)))
-
-(setq test-schema (proto:generate-schema-for-classes
-                   '(proto-test1 proto-test2 proto-test3 proto-test4 proto-test5 proto-test6)
-                   :install t))
-
-(proto:write-schema test-schema)
-(proto:write-schema test-schema :type :lisp)
-
-(dolist (class '(proto-test1 proto-test2 proto-test3 proto-test4 proto-test5 proto-test6))
-  (let ((message (proto-impl:find-message test-schema class)))
-    (eval (proto-impl:generate-object-size  message))
-    (eval (proto-impl:generate-serializer   message))
-    (eval (proto-impl:generate-deserializer message))))
-
-(setq test1  (make-instance 'proto-test1 :intval 150))
-(setq test1b (make-instance 'proto-test1 :intval -150))
-(setq test2  (make-instance 'proto-test2 :strval "testing"))
-(setq test2b (make-instance 'proto-test2 :strval "1 2 3"))
-(setq test3  (make-instance 'proto-test3 :recval test1))
-(setq test4  (make-instance 'proto-test4 :recval test2))
-(setq test5  (make-instance 'proto-test5 :color :red
-                                         :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven")))
-(setq test6  (make-instance 'proto-test6 :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven")
-                                         :recvals (list test2 test2b)))
-
-(setq tser1 (proto:serialize-object-to-stream test1 'proto-test1 :stream nil))
-(equalp tser1 #(#x08 #x96 #x01))
-(describe (proto:deserialize-object 'proto-test1 tser1))
-
-(setq tser1b (proto:serialize-object-to-stream test1b 'proto-test1 :stream nil))
-(equalp tser1b #(#x08 #xEA #xFE #xFF #xFF #x0F))
-(describe (proto:deserialize-object 'proto-test1 tser1b))
-
-(setq tser2 (proto:serialize-object-to-stream test2 'proto-test2 :stream nil))
-(equalp tser2 #(#x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67))
-(describe (proto:deserialize-object 'proto-test2 tser2))
-
-(setq tser3 (proto:serialize-object-to-stream test3 'proto-test3 :stream nil))
-(equalp tser3 #(#x1A #x03 #x08 #x96 #x01))
-(describe (proto:deserialize-object 'proto-test3 tser3))
-(describe (slot-value (proto:deserialize-object 'proto-test3 tser3) 'recval))
-
-(setq tser4 (proto:serialize-object-to-stream test4 'proto-test4 :stream nil))
-(equalp tser4 #(#x1A #x09 #x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67))
-(describe (proto:deserialize-object 'proto-test4 tser4))
-(describe (slot-value (proto:deserialize-object 'proto-test4 tser4) 'recval))
-
-(setq tser5 (proto:serialize-object-to-stream test5 'proto-test5 :stream nil))
-(equalp tser5 #(#x08 #x00
-                #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))
-(describe (proto:deserialize-object 'proto-test5 tser5))
-
-(setq tser6 (proto:serialize-object-to-stream test6 'proto-test6 :stream nil))
-(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))
-(describe (proto:deserialize-object 'proto-test6 tser6))
-(describe (slot-value (proto:deserialize-object 'proto-test6 tser6) 'recvals))
-
-
-(equalp (mapcar #'proto-impl:zig-zag-encode32
-                '(0 -1 1 -2 2 -2147483648 2147483647))
-        '(0 1 2 3 4 4294967295 4294967294))
-(equalp (mapcar #'proto-impl:zig-zag-encode64
-                '(0 -1 1 -2 2 -2147483648 2147483647 -1152921504606846976 1152921504606846975))
-        '(0 1 2 3 4 4294967295 4294967294 2305843009213693951 2305843009213693950))
-
-(proto:print-text-format test1)
-(proto:print-text-format (proto:deserialize-object 'proto-test1 tser1))
-(let ((text (with-output-to-string (s)
-              (proto:print-text-format test1 'proto-test1 :stream s))))
-  (with-input-from-string (s text)
-    (proto:parse-text-format 'proto-test1 :stream s)))
-
-(proto:print-text-format test2)
-(proto:print-text-format (proto:deserialize-object 'proto-test2 tser2))
-(let ((text (with-output-to-string (s)
-              (proto:print-text-format test2 'proto-test2 :stream s))))
-  (with-input-from-string (s text)
-    (proto:parse-text-format 'proto-test2 :stream s)))
-
-(proto:print-text-format test3)
-(proto:print-text-format (proto:deserialize-object 'proto-test3 tser3))
-(let ((text (with-output-to-string (s)
-              (proto:print-text-format test3 'proto-test3 :stream s))))
-  (with-input-from-string (s text)
-    (proto:parse-text-format 'proto-test3 :stream s)))
-
-(proto:print-text-format test4)
-(proto:print-text-format (proto:deserialize-object 'proto-test4 tser4))
-(let ((text (with-output-to-string (s)
-              (proto:print-text-format test4 'proto-test4 :stream s))))
-  (with-input-from-string (s text)
-    (proto:parse-text-format 'proto-test4 :stream s)))
-
-(proto:print-text-format test5)
-(proto:print-text-format (proto:deserialize-object 'proto-test5 tser5))
-(let ((text (with-output-to-string (s)
-              (proto:print-text-format test5 'proto-test5 :stream s))))
-  (with-input-from-string (s text)
-    (proto:parse-text-format 'proto-test5 :stream s)))
-
-(proto:print-text-format test6)
-(proto:print-text-format (proto:deserialize-object 'proto-test6 tser6))
-(let ((text (with-output-to-string (s)
-              (proto:print-text-format test6 'proto-test6 :stream s))))
-  (with-input-from-string (s text)
-    (proto:parse-text-format 'proto-test6 :stream s)))
-||#
-
-#||
-(let* ((enums (list (make-instance 'proto:protobuf-enum
-                      :name "ColorName"
-                      :values (list (make-instance 'proto:protobuf-enum-value
-                                      :name "RED"
-                                      :index 1
-                                      :value :red)
-                                    (make-instance 'proto:protobuf-enum-value
-                                      :name "GREEN"
-                                      :index 2
-                                      :value :green)
-                                    (make-instance 'proto:protobuf-enum-value
-                                      :name "BLUE"
-                                      :index 3
-                                      :value :blue)))))
-       (msgs  (list (make-instance 'proto:protobuf-message
-                      :name "Color"
-                      :enums (list (make-instance 'proto:protobuf-enum
-                                      :name "ContrastName"
-                                      :values (list (make-instance 'proto:protobuf-enum-value
-                                                      :name "LOW"
-                                                      :index 1
-                                                      :value :high)
-                                                    (make-instance 'proto:protobuf-enum-value
-                                                      :name "HIGH"
-                                                      :index 100
-                                                      :value :low))))
-                      :fields (list (make-instance 'proto:protobuf-field
-                                      :name "color"
-                                      :type "ColorName"
-                                      :required :required
-                                      :index 1)
-                                    (make-instance 'proto:protobuf-field
-                                      :name "contrast"
-                                      :type "ContrastName"
-                                      :required :optional
-                                      :index 2
-                                      :default "LOW")))))
-       (methods  (list (make-instance 'proto:protobuf-method
-                         :name "GetColor"
-                         :input-name "string"
-                         :output-name "Color")
-                       (make-instance 'proto:protobuf-method
-                         :name "SetColor"
-                         :input-name "Color"
-                         :output-name "Color"
-                         :options (list (make-instance 'proto:protobuf-option
-                                          :name "deadline" :value 1.0)))))
-       (svcs  (list (make-instance 'proto:protobuf-service
-                      :name "ColorWheel"
-                      :methods methods)))
-       (proto (make-instance 'proto:protobuf
-                :package "ita.color"
-                :imports '("descriptor.proto")
-                :enums enums
-                :messages msgs
-                :services svcs)))
-  ;; The output should be example the same as the output of 'write-schema' below
-  (proto:write-schema proto))
-||#
-
-#||
-(proto:define-schema color-wheel
-    (:package ita.color
-     :import "descriptor.proto"
-     :documentation "Color wheel example")
-  (proto:define-enum color-name
-      (:documentation "A color name")
-    red
-    green
-    blue)
-  (proto:define-message color
-      (:conc-name color-
-       :documentation "Color and contrast")
-    (proto:define-enum contrast-name
-        (:documentation "A contrast name")
-      (low    1)
-      (high 100))
-    (color    :type color-name)
-    (contrast :type (or null contrast-name) :default :low))
-  (proto:define-service color-wheel
-      (:documentation "Get and set colors")
-    (get-color (string color))
-    (set-color (color color)
-               :options ("deadline" 1.0))))
-
-=> (PROGN
-     (DEFTYPE COLOR-NAME () '(MEMBER :RED :GREEN :BLUE))
-     (DEFTYPE CONTRAST-NAME () '(MEMBER :LOW :HIGH))
-     (DEFCLASS COLOR ()
-       ((COLOR :TYPE COLOR-NAME :ACCESSOR COLOR-COLOR :INITARG :COLOR)
-        (CONTRAST :TYPE (OR NULL CONTRAST-NAME) :ACCESSOR COLOR-CONTRAST :INITARG :CONTRAST :INITFORM :LOW)))
-     (DEFVAR *COLOR-WHEEL*
-       (MAKE-INSTANCE 'PROTOBUF-SCHEMA
-         :NAME "ColorWheel"
-         :CLASS 'COLOR-WHEEL
-         :PACKAGE "ita.color"
-         :IMPORTS '("descriptor.proto")
-         :SYNTAX "proto2"
-         :OPTIONS ()
-         :ENUMS (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM
-                        :NAME "ColorName"
-                        :CLASS 'COLOR-NAME
-                        :VALUES (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
-                                        :NAME "RED" :INDEX 1 :VALUE :RED)
-                                      (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
-                                        :NAME "GREEN" :INDEX 2 :VALUE :GREEN)
-                                      (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
-                                        :NAME "BLUE" :INDEX 3 :VALUE :BLUE))))
-         :MESSAGES (LIST (MAKE-INSTANCE 'PROTOBUF-MESSAGE
-                           :NAME "Color"
-                           :CLASS 'COLOR
-                           :CONC-NAME "COLOR-"
-                           :ENUMS (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM
-                                          :NAME "ContrastName"
-                                          :CLASS 'CONTRAST-NAME
-                                          :VALUES (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
-                                                          :NAME "LOW" :INDEX 1 :VALUE :LOW)
-                                                        (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE
-                                                          :NAME "HIGH" :INDEX 100 :VALUE :HIGH))))
-                           :MESSAGES (LIST)
-                           :FIELDS (LIST (MAKE-INSTANCE 'PROTOBUF-FIELD
-                                           :NAME "color"
-                                           :TYPE "ColorName"
-                                           :CLASS 'COLOR-NAME
-                                           :REQUIRED :REQUIRED
-                                           :INDEX 1
-                                           :VALUE 'COLOR
-                                           :DEFAULT NIL
-                                           :PACKED NIL)
-                                         (MAKE-INSTANCE 'PROTOBUF-FIELD
-                                           :NAME "contrast"
-                                           :TYPE "ContrastName"
-                                           :CLASS 'CONTRAST-NAME
-                                           :REQUIRED :OPTIONAL
-                                           :INDEX 2
-                                           :VALUE 'CONTRAST
-                                           :DEFAULT "LOW"
-                                           :PACKED NIL))))
-         :SERVICES (LIST (MAKE-INSTANCE 'PROTOBUF-SERVICE
-                           :NAME "ColorWheel"
-                           :CLASS 'COLOR-WHEEL
-                           :METHODS (LIST (MAKE-INSTANCE 'PROTOBUF-METHOD
-                                            :NAME "GetColor"
-                                            :CLASS 'GET-COLOR
-                                            :INPUT-NAME "string"
-                                            :OUTPUT-NAME "Color"
-                                            :OPTIONS (LIST))
-                                          (MAKE-INSTANCE 'PROTOBUF-METHOD
-                                            :NAME "SetColor"
-                                            :CLASS 'SET-COLOR
-                                            :INPUT-NAME "Color"
-                                            :OUTPUT-NAME "Color"
-                                            :OPTIONS (LIST (MAKE-INSTANCE 'PROTOBUF-OPTION
-                                                             :NAME "deadline" :VALUE "1.0")))))))))
-
-;; The output should be example the same as the output of 'write-schema' above
-(proto:write-schema *color-wheel*)
-
-;; How does the Lisp version look?
-(proto:write-schema *color-wheel* :type :lisp)
-
-(setq clr (make-instance 'color :color :red))
-(setq cser (proto:serialize-object-to-stream clr 'color :stream nil))
-(proto:print-text-format clr)
-(proto:print-text-format (proto:deserialize-object 'color cser))
-||#
-
-#||
-(let ((ps "package ita.color;
-
-import \"descriptor.proto\";
-
-enum ColorName {
-  RED = 1;
-  GREEN = 2;
-  BLUE = 3;
-}
-
-message Color {
-  enum ContrastName {
-    LOW = 1;
-    HIGH = 100;
-  }
-  required ColorName color = 1;
-  optional ContrastName contrast = 2 [default = LOW];
-}
-
-service ColorWheel {
-  rpc GetColor (string) returns (Color);
-  rpc SetColor (Color) returns (Color) {
-    option deadline = 1.0;
-  }
-}"))
-  (with-input-from-string (s ps)
-    (setq ppp (proto:parse-schema-from-stream s))))
-
-(proto:write-schema ppp)
-(proto:write-schema ppp :type :lisp)
-||#
 
 #||
+;; Lisp lists :-)
 (proto:define-schema typed-list ()
   (proto:define-message typed-list ()
     (string-car  :type (or null string)  :reader string-car)
@@ -558,41 +149,9 @@ service ColorWheel {
       (proto:parse-text-format 'typed-list :stream s))))
 ||#
 
-#||
-(proto:define-schema integrity-test ()
-  (proto:define-message inner ()
-    (i :type (or null integer)))
-  (proto:define-message outer ()
-    (inner :type (proto:list-of inner))
-    (simple :type (or null inner))
-    (i :type (or null integer))))
-
-(defun integrity-test (message)
-  (let* ((type (type-of message))
-         (buf (proto:serialize-object-to-stream message type :stream nil))
-         (new (proto:deserialize-object type buf))
-         (newbuf (proto:serialize-object-to-stream new type :stream nil)))
-    (assert (equalp (length buf) (length newbuf)))
-    (assert (equalp buf newbuf))
-    (assert (string= (with-output-to-string (s)
-                       (proto:print-text-format message nil :stream s))
-                     (with-output-to-string (s)
-                       (proto:print-text-format new nil :stream s))))
-    new))
-
-(integrity-test (make-instance 'outer :i 4))
-
-(integrity-test (make-instance 'outer 
-                  :inner (mapcar #'(lambda (i) (make-instance 'inner :i i)) '(1 2 3))))
-
-(integrity-test (make-instance 'outer 
-                  :simple (make-instance 'inner :i 4)))
-||#
-
-\f
-;;; Stubby examples
 
 #||
+;; Extension example
 (proto:define-schema color-wheel
     (:package color-wheel
      :optimize :speed
@@ -628,83 +187,33 @@ service ColorWheel {
 (proto:write-schema *color-wheel*)
 (proto:write-schema *color-wheel* :type :lisp)
 
-(progn ;with-rpc-channel (rpc)
-  (let* ((wheel  (make-instance 'color-wheel :name "Colors"))
-         (color1 (make-instance 'color :r-value 100 :g-value 0 :b-value 100))
-         (rqst1  (make-instance 'add-color-request :wheel wheel :color color1))
-         (color2 (make-instance 'color :r-value 100 :g-value 0 :b-value 100))
-         (rqst2  (make-instance 'add-color-request :wheel wheel :color color2)))
-    (setf (color-opacity color2) 50)
-    #-ignore (progn
-               (format t "~2&Unextended (has-extension ~S)~%" (has-extension color1 'opacity))
-               (let ((ser1 (proto:serialize-object-to-stream rqst1 'add-color-request :stream nil)))
-                 (print ser1)
-                 (proto:print-text-format rqst1)
-                 (proto:print-text-format (proto:deserialize-object 'add-color-request ser1))))
-    #-ignore (progn 
-               (format t "~2&Extended (has-extension ~S)~%" (has-extension color2 'opacity))
-               (let ((ser2 (proto:serialize-object-to-stream rqst2 'add-color-request :stream nil)))
-                 (print ser2)
-                 (proto:print-text-format rqst2)
-                 (proto:print-text-format (proto:deserialize-object 'add-color-request ser2))))
-    #+stubby (add-color request)
-    #+ignore (add-color request)))
+(let* ((wheel  (make-instance 'color-wheel :name "Colors"))
+       (color1 (make-instance 'color :r-value 100 :g-value 0 :b-value 100))
+       (rqst1  (make-instance 'add-color-request :wheel wheel :color color1))
+       (color2 (make-instance 'color :r-value 100 :g-value 0 :b-value 100))
+       (rqst2  (make-instance 'add-color-request :wheel wheel :color color2)))
+  (setf (color-opacity color2) 50)
+  (progn
+    (format t "~2&Unextended (has-extension ~S)~%" (has-extension color1 'opacity))
+    (let ((ser1 (proto:serialize-object-to-stream rqst1 'add-color-request :stream nil)))
+      (print ser1)
+      (proto:print-text-format rqst1)
+      (proto:print-text-format (proto:deserialize-object 'add-color-request ser1))))
+  (progn 
+    (format t "~2&Extended (has-extension ~S)~%" (has-extension color2 'opacity))
+    (let ((ser2 (proto:serialize-object-to-stream rqst2 'add-color-request :stream nil)))
+      (print ser2)
+      (proto:print-text-format rqst2)
+      (proto:print-text-format (proto:deserialize-object 'add-color-request ser2)))))
 ||#
 
-#||
-(let ((ps "syntax = \"proto2\";
-
-package color_wheel;
-
-option optimize_for = SPEED;
-
-message ColorWheel {
-  required string name = 1;
-  repeated Color colors = 2;
-  optional group Metadata = 3 {
-    optional string author = 1;
-    optional string revision = 2;
-    optional string date = 3;
-  }
-}
-
-message Color {
-  optional string name = 1;
-  required int64 r_value = 2;
-  required int64 g_value = 3;
-  required int64 b_value = 4;
-  extensions 1000 to max;
-}
-
-extend Color {
-  optional int64 opacity = 1000;
-}
-
-message GetColorRequest {
-  required ColorWheel wheel = 1;
-  required string name = 2;
-}
-
-message AddColorRequest {
-  required ColorWheel wheel = 1;
-  required Color color = 2;
-}
-
-service ColorWheel {
-  rpc GetColor (GetColorRequest) returns (Color) {
-    option deadline = 1.0;
-  }
-  rpc AddColor (AddColorRequest) returns (Color) {
-    option deadline = 1.0;
-  }
-}"))
-  (with-input-from-string (s ps)
-    (setq cw (proto:parse-schema-from-stream s))))
 
+#||
+;; Group example
 (proto:define-schema color-wheel1
     (:package color-wheel
      ;; :optimize :speed
-     :documentation "Color wheel example, with nested")
+     :documentation "Color wheel example, with nested message")
   (proto:define-message color-wheel1 ()
     (proto:define-message metadata1 ()
       (author :type (or null string))
@@ -747,25 +256,24 @@ service ColorWheel {
 (proto:write-schema *color-wheel1*)
 (proto:write-schema *color-wheel2*)
 
-(progn ;with-rpc-channel (rpc)
-  (let* ((meta1  (make-instance 'metadata1 :revision "1.0"))
-         (wheel1 (make-instance 'color-wheel1 :name "Colors" :metadata1 meta1))
-         (color1 (make-instance 'color1 :r-value 100 :g-value 0 :b-value 100))
-         (rqst1  (make-instance 'add-color1 :wheel wheel1 :color color1))
-         (meta2  (make-instance 'metadata2 :revision "1.0"))
-         (wheel2 (make-instance 'color-wheel2 :name "Colors" :metadata2 meta2))
-         (color2 (make-instance 'color2 :r-value 100 :g-value 0 :b-value 100))
-         (rqst2  (make-instance 'add-color2 :wheel wheel2 :color color2)))
-    #-ignore (progn
-               (format t "~2&Nested")
-               (let ((ser1 (proto:serialize-object-to-stream rqst1 'add-color1 :stream nil)))
-                 (print ser1)
-                 (proto:print-text-format rqst1)
-                 (proto:print-text-format (proto:deserialize-object 'add-color1 ser1))))
-    #-ignore (progn
-               (format t "~2&Group")
-               (let ((ser2 (proto:serialize-object-to-stream rqst2 'add-color2 :stream nil)))
-                 (print ser2)
-                 (proto:print-text-format rqst2)
-                 (proto:print-text-format (proto:deserialize-object 'add-color2 ser2))))))
+(let* ((meta1  (make-instance 'metadata1 :revision "1.0"))
+       (wheel1 (make-instance 'color-wheel1 :name "Colors" :metadata1 meta1))
+       (color1 (make-instance 'color1 :r-value 100 :g-value 0 :b-value 100))
+       (rqst1  (make-instance 'add-color1 :wheel wheel1 :color color1))
+       (meta2  (make-instance 'metadata2 :revision "1.0"))
+       (wheel2 (make-instance 'color-wheel2 :name "Colors" :metadata2 meta2))
+       (color2 (make-instance 'color2 :r-value 100 :g-value 0 :b-value 100))
+       (rqst2  (make-instance 'add-color2 :wheel wheel2 :color color2)))
+  (progn
+    (format t "~2&Nested")
+    (let ((ser1 (proto:serialize-object-to-stream rqst1 'add-color1 :stream nil)))
+      (print ser1)
+      (proto:print-text-format rqst1)
+      (proto:print-text-format (proto:deserialize-object 'add-color1 ser1))))
+  (progn
+    (format t "~2&Group")
+    (let ((ser2 (proto:serialize-object-to-stream rqst2 'add-color2 :stream nil)))
+      (print ser2)
+      (proto:print-text-format rqst2)
+      (proto:print-text-format (proto:deserialize-object 'add-color2 ser2)))))
 ||#

diff --git a/model-classes.lisp b/model-classes.lisp
index 4b8bb231815eaf1c1511d3bd696ff5a351e8e145..308a725f08f1d74873ff925c1ffa56577f0aea9b 100644 (file)
--- a/model-classes.lisp
+++ b/model-classes.lisp
@@ -231,6 +231,25 @@
     (and option
          (values (proto-value option) (proto-type option)))))
 
+(defgeneric remove-option (protobuf names)
+  (:documentation
+   "Given a protobuf schema, message, enum, etc and a set of option names,
+    remove all of those options from the set of options."))
+
+(defmethod remove-options ((protobuf base-protobuf) &rest names)
+  (dolist (name names)
+    (let ((option (find name (proto-options protobuf) :key #'proto-name :test #'option-name=)))
+      (when option
+        ;; This side-effects 'proto-options'
+        (setf (proto-options protobuf) (remove option (proto-options protobuf)))))))
+
+(defmethod remove-options ((options list) &rest names)
+  (dolist (name names)
+    (let ((option (find name options :key #'proto-name :test #'option-name=)))
+      (when option
+        ;; This does not side-effect the list of options
+        (remove option options)))))
+
 (defun option-name= (name1 name2)
   (let* ((name1  (string name1))
          (name2  (string name2))

diff --git a/parser.lisp b/parser.lisp
index b434e732dd0aea599a1c6070efd2ad25c5c85127..d01e88b3137431d33993bd761e1b3e9cb42698cb 100644 (file)
--- a/parser.lisp
+++ b/parser.lisp
@@ -240,12 +240,15 @@
     (let ((token (parse-token stream '(#\- #\+ #\.))))
       (when token
         (skip-whitespace stream)
-        (cond ((starts-with token "0x")
-               (parse-integer (subseq token 2) :radix 16))
-              ((starts-with token "-0x")
-               (- (parse-integer (subseq token 3) :radix 16)))
-              (t
-               (read-from-string token)))))))
+        (parse-numeric-string token)))))
+
+(defun parse-numeric-string (string)
+  (cond ((starts-with string "0x")
+         (parse-integer (subseq string 2) :radix 16))
+        ((starts-with string "-0x")
+         (- (parse-integer (subseq string 3) :radix 16)))
+        (t
+         (read-from-string string))))
 
 
 ;;; The parser itself
@@ -278,6 +281,7 @@
       (maybe-skip-comments stream)
       (let ((char (peek-char nil stream nil)))
         (cond ((null char)
+               (remove-options schema "lisp_package")
                (return-from parse-schema-from-stream schema))
               ((proto-token-char-p char)
                (let ((token (parse-token stream)))
@@ -356,7 +360,7 @@
                               (parse-string stream))
                              ((or (digit-char-p ch) (member ch '(#\- #\+ #\.)))
                               (parse-number stream))
-                             (t (parse-token stream))))
+                             (t (kintern (parse-token stream)))))
                 (setq terminator (expect-char stream terminators () "option"))
                 (maybe-skip-comments stream)))
          (option (make-instance 'protobuf-option
@@ -530,7 +534,7 @@
                        :default default
                        :packed  (and packed (boolean-true-p packed))
                        :message-type (proto-message-type message)
-                       :options opts)))
+                       :options (remove-options opts "default" "packed"))))
         (when extended-from
           (assert (index-within-extensions-p idx extended-from) ()
                   "The index ~D is not in range for extending ~S"

diff --git a/proto-pkgdcl.lisp b/pkgdcl.lisp
similarity index 95%
rename from proto-pkgdcl.lisp
rename to pkgdcl.lisp
index db81b81f5a4e23b8c49beff0741f35a54c7e3cec..cc624cdc2de7b8c4645fc8e7a00e1ec8a0bd9f63 100644 (file)
--- a/proto-pkgdcl.lisp
+++ b/pkgdcl.lisp
@@ -11,7 +11,7 @@
 (in-package "CL-USER")
 
 
-;;; Package declaration for Protoubfs
+;;; Package declaration for Protobufs
 
 (defpackage protobufs
   (:nicknames :proto)
@@ -166,6 +166,7 @@
    "FIND-ENUM"
    "FIND-FIELD"
    "FIND-OPTION"
+   "REMOVE-OPTIONS"
 
    ;; Printing
    "WRITE-SCHEMA-AS"
@@ -187,12 +188,15 @@
    "SERIALIZE-PRIM"
    "SERIALIZE-PACKED"
    "SERIALIZE-ENUM"
+   "SERIALIZE-PACKED-ENUM"
    "DESERIALIZE-PRIM"
    "DESERIALIZE-PACKED"
    "DESERIALIZE-ENUM"
+   "DESERIALIZE-PACKED-ENUM"
    "PRIM-SIZE"
    "PACKED-SIZE"
    "ENUM-SIZE"
+   "PACKED-ENUM-SIZE"
    "GENERATE-SERIALIZER"
    "GENERATE-DESERIALIZER"
    "GENERATE-OBJECT-SIZE"
@@ -209,6 +213,8 @@
    "ENCODE-UINT64"
    "ENCODE-FIXED32"
    "ENCODE-FIXED64"
+   "ENCODE-SFIXED32"
+   "ENCODE-SFIXED64"
    "ENCODE-SINGLE"
    "ENCODE-DOUBLE"
    "ENCODE-STRING"
@@ -221,6 +227,8 @@
    "DECODE-INT64"
    "DECODE-FIXED32"
    "DECODE-FIXED64"
+   "DECODE-SFIXED32"
+   "DECODE-SFIXED64"
    "DECODE-SINGLE"
    "DECODE-DOUBLE"
    "DECODE-STRING"

diff --git a/printer.lisp b/printer.lisp
index 5869c56c229a0f23ccb739806ed3287ba54f0929..8021adb27ee98e6502b586e3d530302e065da28d 100644 (file)
--- a/printer.lisp
+++ b/printer.lisp
@@ -94,7 +94,7 @@
 
 (defun cl-user::protobuf-option (stream option colon-p atsign-p)
   (let ((type (or (second (find (proto-name option) *option-types* :key #'first :test #'string=))
-                  'string)))
+                  (proto-type option))))
     (cond (colon-p                              ;~:/protobuf-option/ -- .proto format
            (let ((fmt-control
                   (cond ((find (proto-name option) *lisp-options* :key #'first :test #'string=)
@@ -103,9 +103,11 @@
                          (if (eq type 'symbol) "~A~@[ = ~A~]" "~A~@[ = ~S~]")))))
              (format stream fmt-control (proto-name option) (proto-value option))))
           (atsign-p                             ;~@/protobuf-option/ -- .lisp format
-           (format stream "~S ~S" (proto-name option) (proto-value option)))
+           (let ((fmt-control (if (eq type 'symbol) "~(~S~) ~A" "~(~S~) ~S")))
+             (format stream fmt-control (proto-name option) (proto-value option))))
           (t                                    ;~/protobuf-option/  -- keyword/value format
-           (format stream "~(:~A~) ~S" (proto-name option) (proto-value option))))))
+           (let ((fmt-control (if (eq type 'symbol) "~(:~A~) ~A" "~(:~A~) ~S")))
+             (format stream fmt-control (proto-name option) (proto-value option)))))))
 
 (defmethod write-schema-as ((type (eql :proto)) (enum protobuf-enum) stream
                             &key (indentation 0) more)
@@ -204,20 +206,18 @@
 (defmethod write-schema-as ((type (eql :proto)) (field protobuf-field) stream
                             &key (indentation 0) more message)
   (declare (ignore more))
-  (with-prefixed-accessors (name documentation required type index packed) (proto- field)
+  (with-prefixed-accessors (name documentation required type index packed options) (proto- field)
     (let* ((class (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
            (msg   (and (not (keywordp class))
-                       (or (find-message message class) (find-enum message class))))
-           (options (remove-if #'(lambda (x) (or (string= (proto-name x) "default")
-                                                 (string= (proto-name x) "packed")))
-                               (proto-options field))))
+                       (or (find-message message class) (find-enum message class)))))
       (cond ((and (typep msg 'protobuf-message)
                   (eq (proto-message-type msg) :group))
              (format stream "~&~@[~VT~]~(~A~) "
                      (and (not (zerop indentation)) indentation) required)
              (write-schema-as :proto msg stream :indentation indentation :index index :arity required))
             ((typep msg 'protobuf-enum)
-             (let ((default (let ((e (find (proto-default field) (proto-values msg) :key #'proto-name :test #'string=)))
+             (let ((default (let ((e (find (proto-default field) (proto-values msg)
+                                           :key #'proto-name :test #'string=)))
                               (and e (proto-name e)))))
               (format stream "~&~@[~VT~]~(~A~) ~A ~A = ~D~
                               ~@[ [default = ~A]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~
@@ -503,7 +503,7 @@
 (defparameter *protobuf-slot-comment-column* 56)
 (defmethod write-schema-as ((type (eql :lisp)) (field protobuf-field) stream
                             &key (indentation 0) more message)
-  (with-prefixed-accessors (value reader writer required index packed documentation) (proto- field)
+  (with-prefixed-accessors (value reader writer required index packed options documentation) (proto- field)
     (let* ((class (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
            (msg   (and (not (keywordp class))
                        (or (find-message message class) (find-enum message class))))
@@ -529,10 +529,7 @@
                            `(or null ,cl))
                           ((eq required :repeated)
                            `(list-of ,cl))
-                          (t cl))))
-           (options (remove-if #'(lambda (x) (or (string= (proto-name x) "default")
-                                                 (string= (proto-name x) "packed")))
-                               (proto-options field))))
+                          (t cl)))))
       (cond ((and (typep msg 'protobuf-message)
                   (eq (proto-message-type msg) :group))
              (write-schema-as :lisp msg stream :indentation indentation :index index :arity required))
@@ -541,7 +538,8 @@
                     (defaultp (not (null default)))
                     (default 
                       (cond ((and (typep msg 'protobuf-enum) (stringp default))
-                             (let ((e (find default (proto-values msg) :key #'proto-name :test #'string=)))
+                             (let ((e (find default (proto-values msg)
+                                            :key #'proto-name :test #'string=)))
                                (and e (proto-value e))))
                             ((and (eq class :bool) defaultp)
                              (boolean-true-p default))

diff --git a/protobufs.asd b/protobufs.asd
index 898e54e84de7dc94f3461ca83642baa12e0ce449..56f17e0a8835a85b97b443e6efc5f4c51ffb815e 100644 (file)
--- a/protobufs.asd
+++ b/protobufs.asd
@@ -11,11 +11,10 @@
 (in-package "CL-USER")
 
 
-(defsystem :protobufs
+(asdf:defsystem :protobufs
     :name "Protobufs"
     :author "Scott McKay"
-    :version "0.1"
-    :maintainer '("Scott McKay")
+    :version "1.0"
     :licence "
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;                                                                  ;;;
@@ -26,30 +25,54 @@
 ;;; Original author: Scott McKay                                     ;;;
 ;;;                                                                  ;;;
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;"
+    :maintainer '("Scott McKay")
     :description      "Protobufs for Common Lisp"
     :long-description "Protobufs for Common Lisp"
-    :depends-on (:cl-ppcre
-                 :closer-mop
-                 :split-sequence
-                 :drakma
-                 :cl-unicode)
+    :depends-on (:cl-ppcre :closer-mop :split-sequence :drakma :cl-unicode)
     :serial t
     :components
-      ((:module "protobufs"
+      ((:module "packages"
+                :serial t
+                :pathname #p""
+                :components
+                 ((:file "pkgdcl")))
+       (:module "models"
+                :serial t
+                :pathname #p""
+                :depends-on ("packages")
+                :components
+                  ((:file "utilities")
+                   (:file "model-classes")))
+       (:module "parsing"
+                :serial t
+                :pathname #p""
+                :depends-on ("models")
+                :components
+                  ((:file "printer")
+                   (:file "parser")))
+       (:module "schema"
+                :serial t
+                :pathname #p""
+                :depends-on ("models")
+                :components
+                  ((:file "define-proto")
+                   (:file "upgradable")
+                   (:file "clos-transform")))
+       (:module "serialization"
+                :serial t
+                :pathname #p""
+                :depends-on ("models")
+                :components
+                  ((:file "text-format")
+                   (:file "wire-format")
+                   (:file "serialize")))
+       (:module "misc"
                 :serial t
-                :components ((:file "proto-pkgdcl")
-                             (:file "utilities")
-                             (:file "model-classes")
-                             (:file "printer")
-                             (:file "parser")
-                             (:file "define-proto")
-                             (:file "upgradable")
-                             (:file "clos-transform")
-                             (:file "wire-format")
-                             (:file "text-format")
-                             (:file "serialize")
-                             (:file "api")
-                             (:file "asdf-support")
-                             (:file "examples")))))
+                :pathname #p""
+                :depends-on ("models" "parsing" "schema" "serialization")
+                :components
+                  ((:file "api")
+                   (:file "asdf-support")
+                   (:file "examples")))))
 
 

diff --git a/upgradable.lisp b/upgradable.lisp
index f6d3c37f38962d90d88db7333aa751725c7614cf..6c733d6843a3a3a2da02bff8764f3d8cdf6960a0 100644 (file)
--- a/upgradable.lisp
+++ b/upgradable.lisp
@@ -191,8 +191,11 @@
 ;; These methods are pretty similar to the 'schema-upgradable' methods above
 (defmethod schemas-equal ((schema1 protobuf-schema) (schema2 protobuf-schema))
   (and
-   (eql    (proto-class schema1) (proto-class schema2))
-   (equalp (proto-name schema1) (proto-name schema2))
+   ;; If the name(s) are null, don't worry about them
+   (or (null (proto-class schema1)) (null (proto-class schema2))
+       (eql (proto-class schema1) (proto-class schema2)))
+   (or (null (proto-name schema1)) (null (proto-name schema2))
+        (equalp (proto-name schema1) (proto-name schema2)))
    (equalp (proto-syntax schema1) (proto-syntax schema2))
    (equalp (proto-package schema1) (proto-package schema2))
    (equalp (proto-lisp-package schema1) (proto-lisp-package schema2))

diff --git a/wire-format.lisp b/wire-format.lisp
index c000057d8772b6ce14bcb0eb7ac5845ff13801c9..fe212fdb9e9ea667e8c19a41ce7da967c3baebb2 100644 (file)
--- a/wire-format.lisp
+++ b/wire-format.lisp
@@ -1024,8 +1024,8 @@
           do (setq val (ilogior val (iash byte places))))
     (values val index)))
 
-(defun decode-sfixed32 (buffer index)
-  "Decodes the next 32-bit signed fixed integer in the buffer at the given index.
+(defun decode-fixed64 (buffer index)
+  "Decodes the next unsigned 64-bit fixed integer in the buffer at the given index.
    Returns both the decoded value and the new index into the buffer.
    Watch out, this function turns off all type checking and array bounds checking."
   (declare (optimize (speed 3) (safety 0) (debug 0)))
@@ -1033,17 +1033,14 @@
            (type fixnum index))
   ;; Eight bits at a time, least significant bits first
   (let ((val 0))
-    (declare (type fixnum val))
-    (loop repeat 4
+    (loop repeat 8
           for places fixnum upfrom 0 by 8
           for byte fixnum = (prog1 (aref buffer index) (iincf index))
-          do (setq val (ilogior val (iash byte places))))
-    (when (i= (ldb (byte 1 31) val) 1)              ;sign bit set, so negative value
-      (decf val #.(ash 1 32)))
+          do (setq val (logior val (ash byte places))))
     (values val index)))
 
-(defun decode-fixed64 (buffer index)
-  "Decodes the next unsigned 64-bit fixed integer in the buffer at the given index.
+(defun decode-sfixed32 (buffer index)
+  "Decodes the next 32-bit signed fixed integer in the buffer at the given index.
    Returns both the decoded value and the new index into the buffer.
    Watch out, this function turns off all type checking and array bounds checking."
   (declare (optimize (speed 3) (safety 0) (debug 0)))
@@ -1051,10 +1048,13 @@
            (type fixnum index))
   ;; Eight bits at a time, least significant bits first
   (let ((val 0))
-    (loop repeat 8
+    (declare (type fixnum val))
+    (loop repeat 4
           for places fixnum upfrom 0 by 8
           for byte fixnum = (prog1 (aref buffer index) (iincf index))
-          do (setq val (logior val (ash byte places))))
+          do (setq val (ilogior val (iash byte places))))
+    (when (i= (ldb (byte 1 31) val) 1)              ;sign bit set, so negative value
+      (decf val #.(ash 1 32)))
     (values val index)))
 
 (defun decode-sfixed64 (buffer index)