Fully implement 'extends'

git-svn-id: http://svn.internal.itasoftware.com/svn/ita/branches/qres/swm/borgify-1/qres/lisp/quux/protobufs@539924 f8382938-511b-0410-9cdd-bb47b084005c

diff --git a/cl-protobufs.rst b/cl-protobufs.rst
index 1fd66f4e9ca0228b98b5f5218ecd90bd9c15da63..0a19630fe7b0d205edb7264666033eb16a045299 100644 (file)
--- a/cl-protobufs.rst
+++ b/cl-protobufs.rst
@@ -239,19 +239,20 @@ You can define a Protobufs schema entirely within Lisp by using the
 following macros. For example::
 
   (proto:define-proto color-wheel
 following macros. For example::
 
   (proto:define-proto color-wheel

-      (:package color-wheel
-       :documentation "Color wheel example")
+      (:package color-wheel)

     (proto:define-message color-wheel
         (:conc-name color-wheel-)
       (name   :type string)
       (colors :type (proto:list-of color) :default ()))
     (proto:define-message color
     (proto:define-message color-wheel
         (:conc-name color-wheel-)
       (name   :type string)
       (colors :type (proto:list-of color) :default ()))
     (proto:define-message color

-        (:conc-name color-
-         :documentation "A (named) color")
+        (:conc-name color-)

       (name    :type (or string null))
       (r-value :type integer)
       (g-value :type integer)
       (name    :type (or string null))
       (r-value :type integer)
       (g-value :type integer)

-      (b-value :type integer))
+      (b-value :type integer)
+      (proto:define-extension 1000 max))
+    (proto:define-extends color ()
+      ((opacity 1000) :type (or null integer)))

     (proto:define-message get-color-request ()
       (wheel :type color-wheel)
       (name  :type string))
     (proto:define-message get-color-request ()
       (wheel :type color-wheel)
       (name  :type string))


@@ -260,11 +261,9 @@ following macros. For example::
       (color :type color))
     (proto:define-service color-wheel ()
       (get-color (get-color-request color)
       (color :type color))
     (proto:define-service color-wheel ()
       (get-color (get-color-request color)

-        :options ("deadline" "1.0")
-        :documentation "Look up a color by name")
+        :options ("deadline" "1.0"))

       (add-color (add-color-request color)
       (add-color (add-color-request color)

-        :options ("deadline" "1.0")
-        :documentation "Add a new color to the wheel")))
+        :options ("deadline" "1.0"))))

 
 This will create the Protobufs model objects, Lisp classes and enum
 types that correspond to the model. The .proto file of the same schema
 
 This will create the Protobufs model objects, Lisp classes and enum
 types that correspond to the model. The .proto file of the same schema


@@ -274,6 +273,14 @@ looks like this::
 
   package color_wheel;
 
 
   package color_wheel;
 

+  import "net/proto2/proto/descriptor.proto"
+
+  extend proto2.MessageOptions {
+    optional string lisp_package = 195801;
+    optional string lisp_name = 195802;
+    optional string lisp_alias = 195803;
+  }
+

   message ColorWheel {
     required string name = 1;
     repeated Color colors = 2;
   message ColorWheel {
     required string name = 1;
     repeated Color colors = 2;


@@ -284,6 +291,11 @@ looks like this::
     required int64 rValue = 2;
     required int64 gValue = 3;
     required int64 bValue = 4;
     required int64 rValue = 2;
     required int64 gValue = 3;
     required int64 bValue = 4;

+    extensions 1000 to max;
+  }
+
+  extends Color {
+    optional int64 opacity = 1000;

   }
 
   message GetColorRequest {
   }
 
   message GetColorRequest {

diff --git a/define-proto.lisp b/define-proto.lisp
index 39279ce8ab46f61167b0e261d6d588b74af49dde..84c22c373553a70bbdc16fdeab2cefdd138bf701 100644 (file)
--- a/define-proto.lisp
+++ b/define-proto.lisp
@@ -46,7 +46,8 @@
                      :optimize optimize
                      :documentation documentation))
          (*protobuf* protobuf)
                      :optimize optimize
                      :documentation documentation))
          (*protobuf* protobuf)

-         (*protobuf-package* nil))
+         (*protobuf-package* (or (find-package lisp-pkg)
+                                 (find-package (string-upcase lisp-pkg)))))

     (with-collectors ((forms collect-form))
       (dolist (msg messages)
         (assert (and (listp msg)
     (with-collectors ((forms collect-form))
       (dolist (msg messages)
         (assert (and (listp msg)


@@ -68,7 +69,9 @@
              (setf (proto-enums protobuf) (nconc (proto-messages protobuf) (list model))))
             ((define-message define-extends)
              (setf (proto-parent model) protobuf)
              (setf (proto-enums protobuf) (nconc (proto-messages protobuf) (list model))))
             ((define-message define-extends)
              (setf (proto-parent model) protobuf)

-             (setf (proto-messages protobuf) (nconc (proto-messages protobuf) (list model))))
+             (setf (proto-messages protobuf) (nconc (proto-messages protobuf) (list model)))
+             (when (proto-extension-p model)
+               (setf (proto-extenders protobuf) (nconc (proto-extenders protobuf) (list model)))))

             ((define-service)
              (setf (proto-services protobuf) (nconc (proto-services protobuf) (list model)))))))
       (let ((var (fintern "*~A*" type)))
             ((define-service)
              (setf (proto-services protobuf) (nconc (proto-services protobuf) (list model)))))))
       (let ((var (fintern "*~A*" type)))


@@ -117,7 +120,6 @@
                   :alias-for alias-for
                   :options options
                   :documentation documentation)))
                   :alias-for alias-for
                   :options options
                   :documentation documentation)))

-    (declare (type fixnum index))

     (with-collectors ((vals  collect-val)
                       (forms collect-form))
       (dolist (val values)
     (with-collectors ((vals  collect-val)
                       (forms collect-form))
       (dolist (val values)


@@ -178,68 +180,38 @@
                     :alias-for alias-for
                     :conc-name (and conc-name (string conc-name))
                     :options  options
                     :alias-for alias-for
                     :conc-name (and conc-name (string conc-name))
                     :options  options

-                    :documentation documentation)))
-    (declare (type fixnum index))
+                    :documentation documentation))
+         (*protobuf* message))

     (with-collectors ((slots collect-slot)
                       (forms collect-form))
     (with-collectors ((slots collect-slot)
                       (forms collect-form))

-      (dolist (fld fields)
-        (case (car fld)
+      (dolist (field fields)
+        (case (car field)

           ((define-enum define-message define-extends define-extension)
            (destructuring-bind (&optional progn type model definers)
           ((define-enum define-message define-extends define-extension)
            (destructuring-bind (&optional progn type model definers)

-               (macroexpand-1 fld env)
+               (macroexpand-1 field env)

              (assert (eq progn 'progn) ()
              (assert (eq progn 'progn) ()

-                     "The macroexpansion for ~S failed" fld)
+                     "The macroexpansion for ~S failed" field)

              (map () #'collect-form definers)
              (ecase type
                ((define-enum)
                 (setf (proto-enums message) (nconc (proto-messages message) (list model))))
                ((define-message define-extends)
                 (setf (proto-parent model) message)
              (map () #'collect-form definers)
              (ecase type
                ((define-enum)
                 (setf (proto-enums message) (nconc (proto-messages message) (list model))))
                ((define-message define-extends)
                 (setf (proto-parent model) message)

-                (setf (proto-messages message) (nconc (proto-messages message) (list model))))
+                (setf (proto-messages message) (nconc (proto-messages message) (list model)))
+                (when (proto-extension-p model)
+                  (setf (proto-extenders message) (nconc (proto-extenders message) (list model)))))

                ((define-extension)
                 (setf (proto-extensions message) (nconc (proto-extensions message) (list model)))))))
           (otherwise
                ((define-extension)
                 (setf (proto-extensions message) (nconc (proto-extensions message) (list model)))))))
           (otherwise

-           (when (i= index 18999)                       ;skip over the restricted range
-             (setq index 19999))
-           (destructuring-bind (slot &key type (default nil default-p) reader writer name documentation) fld
-             (let* ((idx  (if (listp slot) (second slot) (iincf index)))
-                    (slot (if (listp slot) (first slot) slot))
-                    (reqd (clos-type-to-protobuf-required type))
-                    (reader (if (eq reader 't)
-                              (intern (if conc-name (format nil "~A~A" conc-name slot) (symbol-name slot))
-                                      (symbol-package slot))
-                              reader)))
-               (multiple-value-bind (ptype pclass)
-                   (clos-type-to-protobuf-type type)
-                 (unless alias-for
-                   (collect-slot `(,slot :type ,type
-                                         ,@(and reader
-                                                (if writer
-                                                  `(:reader ,reader)
-                                                  `(:accessor ,reader)))
-                                         ,@(and writer
-                                                `(:writer ,writer))
-                                         :initarg ,(kintern (symbol-name slot))
-                                         ,@(cond ((and (not default-p) (eq reqd :repeated))
-                                                  `(:initform ()))
-                                                 ((and (not default-p) (eq reqd :optional))
-                                                  `(:initform nil))
-                                                 (default-p
-                                                   `(:initform ,default))))))
-                 (let ((field (make-instance 'protobuf-field
-                                :name  (or name (slot-name->proto slot))
-                                :type  ptype
-                                :class pclass
-                                :required reqd
-                                :index  idx
-                                :value  slot
-                                :reader reader
-                                :writer writer
-                                :default (and default (format nil "~A" default))
-                                :packed  (and (eq reqd :repeated)
-                                              (packed-type-p pclass))
-                                :documentation documentation)))
-                   (setf (proto-fields message) (nconc (proto-fields message) (list field))))))))))
+           (multiple-value-bind (field slot idx)
+               (process-field field index :conc-name conc-name :alias-for alias-for)
+             (assert (not (find (proto-index field) (proto-fields message) :key #'proto-index)) ()
+                     "The field ~S overlaps with another field in ~S"
+                     (proto-value field) (proto-class message))
+             (when slot
+               (collect-slot slot))
+             (setf (proto-fields message) (nconc (proto-fields message) (list field)))
+             (setq index idx)))))

       (if alias-for
         ;; If we've got an alias, define a a type that is the subtype of
         ;; the Lisp class that typep and subtypep work
       (if alias-for
         ;; If we've got an alias, define a a type that is the subtype of
         ;; the Lisp class that typep and subtypep work


@@ -255,10 +227,131 @@
 
 (defmacro define-extends (type (&key name options documentation)
                           &body fields &environment env)
 
 (defmacro define-extends (type (&key name options documentation)
                           &body fields &environment env)

-  ;;---*** Handle 'define-extends' here (factor out field "parsing" from above)
-  ;;---*** Note that it handles only fields, not nested message or enums
-  type name options documentation fields env
-  `(progn define-extends nil nil))
+  "Define an extension to the message named 'type'.
+   'name' can be used to override the defaultly generated Protobufs message name.
+   The body consists only  of fields.
+   'options' is a set of keyword/value pairs, both of which are strings.
+
+   Fields take the form (slot &key type name default reader)
+   'slot' can be either a symbol giving the field name, or a list whose
+   first element is the slot name and whose second element is the index.
+   'type' is the type of the slot.
+   'name' can be used to override the defaultly generated Protobufs field name.
+   'default' is the default value for the slot.
+   'reader' is a Lisp slot reader function to use to get the value, instead of
+   using 'slot-value'; this is often used when aliasing an existing class.
+   'writer' is a Lisp slot writer function to use to set the value."
+  (declare (ignore env))
+  (let* ((name    (or name (class-name->proto type)))
+         (options (loop for (key val) on options by #'cddr
+                        collect (make-instance 'protobuf-option
+                                  :name  key
+                                  :value val)))
+         (index   0)
+         (message   (find-message *protobuf* name))
+         (conc-name (and message (proto-conc-name message)))
+         (alias-for (and message (proto-alias-for message)))
+         (extends (and message
+                       (make-instance 'protobuf-message
+                         :class  type
+                         :name   name
+                         :parent (proto-parent message)
+                         :conc-name conc-name
+                         :alias-for alias-for
+                         :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)))
+                         :extension-p t                 ;this message is an extension
+                         :documentation documentation))))
+    (assert message ()
+            "There is no message named ~A to extend" name)
+    (assert (eq type (proto-class message)) ()
+            "The type ~S doesn't match the type of the message being extended ~S"
+            type message)
+    (with-collectors ((forms collect-form))
+      (dolist (field fields)
+        (assert (not (member (car field)
+                             '(define-enum define-message define-extends define-extension))) ()
+                "The body of ~S can only contain field definitions" 'define-extends)
+        (multiple-value-bind (field slot idx)
+            (process-field field index :conc-name conc-name :alias-for alias-for)
+          ;;--- Make sure extension field's index is allowable within 'proto-extensions'
+          (assert (not (find (proto-index field) (proto-fields extends) :key #'proto-index)) ()
+                  "The field ~S overlaps with another field in ~S"
+                  (proto-value field) (proto-class extends))
+          (when slot
+            (let* ((inits (cdr slot))
+                   (sname (car slot))
+                   (stype (getf inits :type))
+                   (reader (or (getf inits :accessor)
+                               (getf inits :reader)
+                               (intern (if conc-name (format nil "~A~A" conc-name sname) (symbol-name sname))
+                                       (symbol-package sname))))
+                   (writer (or (getf inits :writer) `(setf ,reader)))
+                   (default (getf inits :initform)))
+              ;;--- Can we avoid having to use a hash table?
+              (collect-form `(let ((,sname (make-hash-table :test #'eq :weak t)))
+                               (defmethod ,reader ((object ,type))
+                                 (gethash object ,sname ,default))
+                               (defmethod ,writer (value (object ,type))
+                                 (declare (type ,stype value))
+                                 (setf (gethash object ,sname) value))))
+              ;; This so that (de)serialization works
+              (setf (proto-reader field) reader
+                    (proto-writer field) writer)))
+          (setf (proto-extension-p field) t)            ;this field is an extension
+          (setf (proto-fields extends) (nconc (proto-fields extends) (list field)))
+          (setq index idx)))
+      `(progn
+         define-extends
+         ,extends
+         ,forms))))
+
+(defun process-field (field index &key conc-name alias-for)
+  "Process one field descriptor within 'define-message' or 'define-extends'.
+   Returns a 'proto-field' object, a CLOS slot form and the incremented field index."
+  (when (i= index 18999)                                ;skip over the restricted range
+    (setq index 19999))
+  (destructuring-bind (slot &key type (default nil default-p) reader writer name documentation) field
+    (let* ((idx  (if (listp slot) (second slot) (iincf index)))
+           (slot (if (listp slot) (first slot) slot))
+           (reqd (clos-type-to-protobuf-required type))
+           (reader (if (eq reader 't)
+                     (intern (if conc-name (format nil "~A~A" conc-name slot) (symbol-name slot))
+                             (symbol-package slot))
+                     reader)))
+      (multiple-value-bind (ptype pclass)
+          (clos-type-to-protobuf-type type)
+        (let ((slot (unless alias-for
+                      `(,slot :type ,type
+                              ,@(and reader
+                                     (if writer
+                                       `(:reader ,reader)
+                                       `(:accessor ,reader)))
+                              ,@(and writer
+                                     `(:writer ,writer))
+                              :initarg ,(kintern (symbol-name slot))
+                              ,@(cond ((and (not default-p) (eq reqd :repeated))
+                                       `(:initform ()))
+                                      ((and (not default-p) (eq reqd :optional))
+                                       `(:initform nil))
+                                      (default-p
+                                        `(:initform ,default))))))
+              (field (make-instance 'protobuf-field
+                       :name  (or name (slot-name->proto slot))
+                       :type  ptype
+                       :class pclass
+                       :required reqd
+                       :index  idx
+                       :value  slot
+                       :reader reader
+                       :writer writer
+                       :default (and default (format nil "~A" default))
+                       :packed  (and (eq reqd :repeated)
+                                     (packed-type-p pclass))
+                       :documentation documentation)))
+          (values field slot index))))))

 
 (defmacro define-extension (from to)
   "Define an extension range within a message.
 
 (defmacro define-extension (from to)
   "Define an extension range within a message.


@@ -267,7 +360,7 @@
      define-extension
      ,(make-instance 'protobuf-extension
         :from from
      define-extension
      ,(make-instance 'protobuf-extension
         :from from

-        :to   to)
+        :to   (if (eql to 'max) #.(1- (ash 1 29)) to))

      ()))
 
 ;; Define a service named 'type' with generic functions declared for
      ()))
 
 ;; Define a service named 'type' with generic functions declared for

diff --git a/examples.lisp b/examples.lisp
index 905b7c93745bb8554b623bb1d4af21f540dc9523..acf67683bb2fec4174330f438f28e7415758c0ee 100644 (file)
--- a/examples.lisp
+++ b/examples.lisp
@@ -536,7 +536,10 @@ service ColorWheel {
     (name    :type (or string null))
     (r-value :type integer)
     (g-value :type integer)
     (name    :type (or string null))
     (r-value :type integer)
     (g-value :type integer)

-    (b-value :type integer))
+    (b-value :type integer)
+    (proto:define-extension 1000 max))
+  (proto:define-extends color ()
+    ((opacity 1000) :type (or null integer)))

   (proto:define-message get-color-request ()
     (wheel :type color-wheel)
     (name  :type string))
   (proto:define-message get-color-request ()
     (wheel :type color-wheel)
     (name  :type string))


@@ -555,10 +558,20 @@ service ColorWheel {
 (proto:write-protobuf *color-wheel* :type :lisp)
 
 (progn ;with-rpc-channel (rpc)
 (proto:write-protobuf *color-wheel* :type :lisp)
 
 (progn ;with-rpc-channel (rpc)

-  (let* ((wheel (make-instance 'color-wheel :name "Colors"))
-         (color (make-instance 'color :r-value 100 :g-value 0 :b-value 100))
-         (request (make-instance 'add-color-request :wheel wheel :color color)))
-    #-ignore (print (proto:serialize-object-to-stream request 'add-color-request :stream nil))
-    #-ignore (proto:print-text-format request)
-    #+stubby (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)
+    #-ignore (let ((ser (proto:serialize-object-to-stream rqst1 'add-color-request :stream nil)))
+               (print ser)
+               (proto:print-text-format rqst1)
+               (proto:print-text-format (proto:deserialize-object 'add-color-request ser)))
+    #-ignore (let ((ser (proto:serialize-object-to-stream rqst2 'add-color-request :stream nil)))
+               (print ser)
+               (proto:print-text-format rqst2)
+               (proto:print-text-format (proto:deserialize-object 'add-color-request ser)))
+    #+stubby (add-color request)
+    #+ignore (add-color request)))

 ||#
 ||#

diff --git a/model-classes.lisp b/model-classes.lisp
index 9af977dc04d1a31942c85b47f94339cc39aab7cb..00a493461ce91909680e43d8a440688ced0412c3 100644 (file)
--- a/model-classes.lisp
+++ b/model-classes.lisp
@@ -90,6 +90,10 @@
              :accessor proto-messages
              :initarg :messages
              :initform ())
              :accessor proto-messages
              :initarg :messages
              :initform ())

+   (extenders :type (list-of protobuf-message)  ;the set of extended messages
+              :accessor proto-extenders
+              :initarg :extenders
+              :initform ())

    (services :type (list-of protobuf-service)
              :accessor proto-services
              :initarg :services
    (services :type (list-of protobuf-service)
              :accessor proto-services
              :initarg :services


@@ -101,8 +105,10 @@
   (declare (ignore initargs))
   ;; Record this schema under both its Lisp and its Protobufs name
   (with-slots (class name) protobuf
   (declare (ignore initargs))
   ;; Record this schema under both its Lisp and its Protobufs name
   (with-slots (class name) protobuf

-    (setf (gethash class *all-protobufs*) protobuf)
-    (setf (gethash name *all-protobufs*) protobuf)))
+    (when class
+      (setf (gethash class *all-protobufs*) protobuf))
+    (when name
+      (setf (gethash name *all-protobufs*) protobuf))))

 
 (defmethod make-load-form ((p protobuf) &optional environment)
   (make-load-form-saving-slots p :environment environment))
 
 (defmethod make-load-form ((p protobuf) &optional environment)
   (make-load-form-saving-slots p :environment environment))


@@ -118,13 +124,16 @@
     returns the protobuf message corresponding to the type."))
 
 (defmethod find-message ((protobuf protobuf) (type symbol))
     returns the protobuf message corresponding to the type."))
 
 (defmethod find-message ((protobuf protobuf) (type symbol))

-  (find type (proto-messages protobuf) :key #'proto-class))
+  ;; Extended messages "shadow" non-extended ones
+  (or (find type (proto-extenders protobuf) :key #'proto-class)
+      (find type (proto-messages protobuf) :key #'proto-class)))

 
 (defmethod find-message ((protobuf protobuf) (type class))
   (find-message protobuf (class-name type)))
 
 (defmethod find-message ((protobuf protobuf) (type string))
 
 (defmethod find-message ((protobuf protobuf) (type class))
   (find-message protobuf (class-name type)))
 
 (defmethod find-message ((protobuf protobuf) (type string))

-  (find type (proto-messages protobuf) :key #'proto-name :test #'string=))
+  (or (find type (proto-extenders protobuf) :key #'proto-name :test #'string=)
+      (find type (proto-messages protobuf) :key #'proto-name :test #'string=)))

 
 (defgeneric find-enum (protobuf type)
   (:documentation
 
 (defgeneric find-enum (protobuf type)
   (:documentation


@@ -231,6 +240,10 @@
              :accessor proto-messages
              :initarg :messages
              :initform ())
              :accessor proto-messages
              :initarg :messages
              :initform ())

+   (extenders :type (list-of protobuf-message)  ;the set of extended messages
+              :accessor proto-extenders
+              :initarg :extenders
+              :initform ())

    (fields :type (list-of protobuf-field)       ;the fields
            :accessor proto-fields
            :initarg :fields
    (fields :type (list-of protobuf-field)       ;the fields
            :accessor proto-fields
            :initarg :fields


@@ -249,8 +262,9 @@
 (defmethod initialize-instance :after ((message protobuf-message) &rest initargs)
   (declare (ignore initargs))
   ;; Record this message under just its Lisp class name
 (defmethod initialize-instance :after ((message protobuf-message) &rest initargs)
   (declare (ignore initargs))
   ;; Record this message under just its Lisp class name

-  (with-slots (class) message
-    (setf (gethash class *all-messages*) message)))
+  (with-slots (class extension-p) message
+    (when (and class (not extension-p))
+      (setf (gethash class *all-messages*) message))))

 
 (defmethod make-load-form ((m protobuf-message) &optional environment)
   (make-load-form-saving-slots m :environment environment))
 
 (defmethod make-load-form ((m protobuf-message) &optional environment)
   (make-load-form-saving-slots m :environment environment))


@@ -261,14 +275,17 @@
             (proto-class m) (proto-alias-for m))))
 
 (defmethod find-message ((message protobuf-message) (type symbol))
             (proto-class m) (proto-alias-for m))))
 
 (defmethod find-message ((message protobuf-message) (type symbol))

-  (or (find type (proto-messages message) :key #'proto-class)
+  ;; Extended messages "shadow" non-extended ones
+  (or (find type (proto-extenders message) :key #'proto-class)
+      (find type (proto-messages message) :key #'proto-class)

       (find-message (proto-parent message) type)))
 
 (defmethod find-message ((message protobuf-message) (type class))
   (find-message message (class-name type)))
 
 (defmethod find-message ((message protobuf-message) (type string))
       (find-message (proto-parent message) type)))
 
 (defmethod find-message ((message protobuf-message) (type class))
   (find-message message (class-name type)))
 
 (defmethod find-message ((message protobuf-message) (type string))

-  (or (find type (proto-messages message) :key #'proto-name :test #'string=)
+  (or (find type (proto-extenders message) :key #'proto-name :test #'string=)
+      (find type (proto-messages message) :key #'proto-name :test #'string=)

       (find-message (proto-parent message) type)))
 
 (defmethod find-enum ((message protobuf-message) type)
       (find-message (proto-parent message) type)))
 
 (defmethod find-enum ((message protobuf-message) type)


@@ -300,8 +317,8 @@
            :accessor proto-reader               ;if it's supplied, it's used instead of 'value'
            :initarg :reader
            :initform nil)
            :accessor proto-reader               ;if it's supplied, it's used instead of 'value'
            :initarg :reader
            :initform nil)

-   (writer :type (or null symbol)               ;a writer that is used to set the value
-           :accessor proto-writer
+   (writer :type (or null symbol list)          ;a writer that is used to set the value
+           :accessor proto-writer               ;when it's a list, it's something like '(setf title)'

            :initarg :writer
            :initform nil)
    (default :type (or null string)              ;default value, pulled out of the options
            :initarg :writer
            :initform nil)
    (default :type (or null string)              ;default value, pulled out of the options

diff --git a/parser.lisp b/parser.lisp
index 65c1e0c0269de00a7701c2d6eed02c6a0f7d7220..c2bcb68d26213f86b7ca362a1796ad770a9cda83 100644 (file)
--- a/parser.lisp
+++ b/parser.lisp
@@ -206,7 +206,8 @@
                                      (setq *protobuf-package* package)))))))
                        ((string= token "enum")
                         (parse-proto-enum stream protobuf))
                                      (setq *protobuf-package* package)))))))
                        ((string= token "enum")
                         (parse-proto-enum stream protobuf))

-                       ;;---*** Handle "extends" here
+                       ((string= token "extends")
+                        (parse-proto-extends stream protobuf))

                        ((string= token "message")
                         (parse-proto-message stream protobuf))
                        ((string= token "service")
                        ((string= token "message")
                         (parse-proto-message stream protobuf))
                        ((string= token "service")


@@ -249,7 +250,7 @@
     (setf (proto-imports protobuf) (nconc (proto-imports protobuf) (list import)))))
 
 (defun parse-proto-option (stream protobuf &optional (terminator #\;))
     (setf (proto-imports protobuf) (nconc (proto-imports protobuf) (list import)))))
 
 (defun parse-proto-option (stream protobuf &optional (terminator #\;))

-  "Parse a Protobufs option from 'stream'.
+  "Parse a Protobufs option line from 'stream'.

    Updates the 'protobuf' (or message, service, method) to have the option."
   (check-type protobuf (or null base-protobuf))
   (let* ((key (prog1 (parse-parenthesized-token stream)
    Updates the 'protobuf' (or message, service, method) to have the option."
   (check-type protobuf (or null base-protobuf))
   (let* ((key (prog1 (parse-parenthesized-token stream)


@@ -271,7 +272,7 @@
 
 
 (defun parse-proto-enum (stream protobuf)
 
 
 (defun parse-proto-enum (stream protobuf)

-  "Parse a Protobufs enum from 'stream'.
+  "Parse a Protobufs 'enum' from 'stream'.

    Updates the 'protobuf' or 'protobuf-message' object to have the enum."
   (check-type protobuf (or protobuf protobuf-message))
   (let* ((name (prog1 (parse-token stream)
    Updates the 'protobuf' or 'protobuf-message' object to have the enum."
   (check-type protobuf (or protobuf protobuf-message))
   (let* ((name (prog1 (parse-token stream)


@@ -298,7 +299,7 @@
           (parse-proto-enum-value stream enum name))))))
 
 (defun parse-proto-enum-value (stream enum name)
           (parse-proto-enum-value stream enum name))))))
 
 (defun parse-proto-enum-value (stream enum name)

-  "Parse a Protobufs enum vvalue from 'stream'.
+  "Parse a Protobufs enum value from 'stream'.

    Updates the 'protobuf-enum' object to have the enum value."
   (check-type enum protobuf-enum)
   (expect-char stream #\= "enum")
    Updates the 'protobuf-enum' object to have the enum value."
   (check-type enum protobuf-enum)
   (expect-char stream #\= "enum")


@@ -313,7 +314,7 @@
 
 
 (defun parse-proto-message (stream protobuf)
 
 
 (defun parse-proto-message (stream protobuf)

-  "Parse a Protobufs message from 'stream'.
+  "Parse a Protobufs 'message' from 'stream'.

    Updates the 'protobuf' or 'protobuf-message' object to have the message."
   (check-type protobuf (or protobuf protobuf-message))
   (let* ((name (prog1 (parse-token stream)
    Updates the 'protobuf' or 'protobuf-message' object to have the message."
   (check-type protobuf (or protobuf protobuf-message))
   (let* ((name (prog1 (parse-token stream)


@@ -322,7 +323,8 @@
          (message (make-instance 'protobuf-message
                     :class (proto->class-name name *protobuf-package*)
                     :name name
          (message (make-instance 'protobuf-message
                     :class (proto->class-name name *protobuf-package*)
                     :name name

-                    :parent protobuf)))
+                    :parent protobuf))
+         (*protobuf* message))

     (loop
       (let ((token (parse-token stream)))
         (when (null token)
     (loop
       (let ((token (parse-token stream)))
         (when (null token)


@@ -338,7 +340,8 @@
           (return-from parse-proto-message))
         (cond ((string= token "enum")
                (parse-proto-enum stream message))
           (return-from parse-proto-message))
         (cond ((string= token "enum")
                (parse-proto-enum stream message))

-              ;;---*** Handle "extends" here
+              ((string= token "extends")
+               (parse-proto-extends stream message))

               ((string= token "message")
                (parse-proto-message stream message))
               ((member token '("required" "optional" "repeated") :test #'string=)
               ((string= token "message")
                (parse-proto-message stream message))
               ((member token '("required" "optional" "repeated") :test #'string=)


@@ -351,6 +354,47 @@
                (error "Unrecognized token ~A at position ~D"
                       token (file-position stream))))))))
 
                (error "Unrecognized token ~A at position ~D"
                       token (file-position stream))))))))
 

+(defun parse-proto-extends (stream protobuf)
+  "Parse a Protobufs 'extends' from 'stream'.
+   Updates the 'protobuf' or 'protobuf-message' object to have the message."
+  (check-type protobuf (or protobuf protobuf-message))
+  (let* ((name (prog1 (parse-token stream)
+                 (expect-char stream #\{ "extends")
+                 (maybe-skip-comments stream)))
+         (message (find-message *protobuf* name))
+         (extends (and message
+                       (make-instance 'protobuf-message
+                         :class  (proto->class-name name *protobuf-package*)
+                         :name   name
+                         :parent (proto-parent message)
+                         :conc-name (proto-conc-name message)
+                         :alias-for (proto-alias-for message)
+                         :enums    (copy-list (proto-enums message))
+                         :messages (copy-list (proto-messages message))
+                         :fields   (copy-list (proto-fields message))
+                         :extension-p t))))             ;this message is an extension
+    (loop
+      (let ((token (parse-token stream)))
+        (when (null token)
+          (expect-char stream #\} "extends")
+          (maybe-skip-comments stream)
+          (setf (proto-messages protobuf) (nconc (proto-messages protobuf) (list extends)))
+          (setf (proto-extenders protobuf) (nconc (proto-extenders protobuf) (list extends)))
+          (let ((type (find-option extends "lisp_name")))
+            (when type
+              (setf (proto-class extends) (make-lisp-symbol type))))
+          (let ((alias (find-option extends "lisp_alias")))
+            (when alias
+              (setf (proto-alias-for extends) (make-lisp-symbol alias))))
+          (return-from parse-proto-extends))
+        (cond ((member token '("required" "optional" "repeated") :test #'string=)
+               (parse-proto-field stream extends token))
+              ((string= token "option")
+               (parse-proto-option stream extends #\;))
+              (t
+               (error "Unrecognized token ~A at position ~D"
+                      token (file-position stream))))))))
+

 (defun parse-proto-field (stream message required)
   "Parse a Protobufs field from 'stream'.
    Updates the 'protobuf-message' object to have the field."
 (defun parse-proto-field (stream message required)
   "Parse a Protobufs field from 'stream'.
    Updates the 'protobuf-message' object to have the field."


@@ -379,7 +423,9 @@
                    :required (kintern required)
                    :index idx
                    :default dflt
                    :required (kintern required)
                    :index idx
                    :default dflt

-                   :packed  (and packed (string= packed "true")))))
+                   :packed  (and packed (string= packed "true"))
+                   :extension-p (proto-extension-p message))))
+    ;;--- Make sure extension field's index is allowable within 'proto-extensions'

     (let ((slot (find-option opts "lisp_name")))
       (when slot
         (setf (proto-value field) (make-lisp-symbol type))))
     (let ((slot (find-option opts "lisp_name")))
       (when slot
         (setf (proto-value field) (make-lisp-symbol type))))


@@ -416,7 +462,7 @@
 
 
 (defun parse-proto-service (stream protobuf)
 
 
 (defun parse-proto-service (stream protobuf)

-  "Parse a Protobufs service from 'stream'.
+  "Parse a Protobufs 'service' from 'stream'.

    Updates the 'protobuf-protobuf' object to have the service."
   (check-type protobuf protobuf)
   (let* ((name (prog1 (parse-token stream)
    Updates the 'protobuf-protobuf' object to have the service."
   (check-type protobuf protobuf)
   (let* ((name (prog1 (parse-token stream)


@@ -441,7 +487,7 @@
                       token (file-position stream))))))))
 
 (defun parse-proto-method (stream service)
                       token (file-position stream))))))))
 
 (defun parse-proto-method (stream service)

-  "Parse a Protobufs enum vvalue from 'stream'.
+  "Parse a Protobufs method from 'stream'.

    Updates the 'protobuf-service' object to have the method."
   (check-type service protobuf-service)
   (let* ((name (parse-token stream))
    Updates the 'protobuf-service' object to have the method."
   (check-type service protobuf-service)
   (let* ((name (parse-token stream))

diff --git a/printer.lisp b/printer.lisp
index 6ea81cd6cd860792eaa4c70b6493fd94cb7a669e..584d0b974d7d8dfb809ebe2df51c9c0970ebf66d 100644 (file)
--- a/printer.lisp
+++ b/printer.lisp
@@ -139,14 +139,19 @@
     (dolist (option options)
       (format stream "~&~VToption ~:/protobuf-option/;~%"
               (+ indentation 2) option))
     (dolist (option options)
       (format stream "~&~VToption ~:/protobuf-option/;~%"
               (+ indentation 2) option))

-    (dolist (enum (proto-enums message))
-      (write-protobuf-as type enum stream :indentation (+ indentation 2)))
-    (dolist (msg (proto-messages message))
-      (write-protobuf-as type msg stream :indentation (+ indentation 2)))
-    (dolist (field (proto-fields message))
-      (write-protobuf-as type field stream :indentation (+ indentation 2)))
-    (dolist (extension (proto-extensions message))
-      (write-protobuf-as type extension stream :indentation (+ indentation 2)))
+    (cond (extension-p
+           (dolist (field (proto-fields message))
+             (when (proto-extension-p field)
+               (write-protobuf-as type field stream :indentation (+ indentation 2)))))
+          (t
+           (dolist (enum (proto-enums message))
+             (write-protobuf-as type enum stream :indentation (+ indentation 2)))
+           (dolist (msg (proto-messages message))
+             (write-protobuf-as type msg stream :indentation (+ indentation 2)))
+           (dolist (field (proto-fields message))
+             (write-protobuf-as type field stream :indentation (+ indentation 2)))
+           (dolist (extension (proto-extensions message))
+             (write-protobuf-as type extension stream :indentation (+ indentation 2)))))

     (format stream "~&~@[~VT~]}~%"
             (and (not (zerop indentation)) indentation))))
 
     (format stream "~&~@[~VT~]}~%"
             (and (not (zerop indentation)) indentation))))
 


@@ -167,7 +172,7 @@
   (with-prefixed-accessors (from to) (proto-extension- extension)
     (format stream "~&~@[~VT~]extensions ~D to ~D;~%"
             (and (not (zerop indentation)) indentation)
   (with-prefixed-accessors (from to) (proto-extension- extension)
     (format stream "~&~@[~VT~]extensions ~D to ~D;~%"
             (and (not (zerop indentation)) indentation)

-            from to)))
+            from (if (eql to #.(1- (ash 1 29))) "max" to))))

 
 
 (defmethod write-protobuf-as ((type (eql :proto)) (service protobuf-service) stream
 
 
 (defmethod write-protobuf-as ((type (eql :proto)) (service protobuf-service) stream


@@ -308,7 +313,9 @@
             (and (not (zerop indentation)) indentation)
             (if extension-p "extends" "message") class)
     (let ((other (and name (not (string= name (class-name->proto class))) name)))
             (and (not (zerop indentation)) indentation)
             (if extension-p "extends" "message") class)
     (let ((other (and name (not (string= name (class-name->proto class))) name)))

-      (cond ((or alias-for conc-name documentation)
+      (cond (extension-p
+             (format stream " ()"))
+            ((or alias-for conc-name documentation)

              (format stream "~%~@[~VT~](~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
                                         ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
                                         ~:[~*~*~;:conc-name ~(~S~)~@[~%~VT~]~]~
              (format stream "~%~@[~VT~](~:[~*~*~;:name ~(~S~)~@[~%~VT~]~]~
                                         ~:[~*~*~;:alias-for ~(~S~)~@[~%~VT~]~]~
                                         ~:[~*~*~;:conc-name ~(~S~)~@[~%~VT~]~]~


@@ -320,22 +327,29 @@
                      documentation documentation))
             (t
              (format stream " ()"))))
                      documentation documentation))
             (t
              (format stream " ()"))))

-    (loop for (enum . more) on (proto-enums message) doing
-      (write-protobuf-as type enum stream :indentation (+ indentation 2))
-      (when more
-        (terpri stream)))
-    (loop for (msg . more) on (proto-messages message) doing
-      (write-protobuf-as type msg stream :indentation (+ indentation 2))
-      (when more
-        (terpri stream)))
-    (loop for (field . more) on (proto-fields message) doing
-      (write-protobuf-as type field stream :indentation (+ indentation 2))
-      (when more
-        (terpri stream)))
-    (loop for (extension . more) on (proto-extensions message) doing
-      (write-protobuf-as type extension stream :indentation (+ indentation 2))
-      (when more
-        (terpri stream)))
+    (cond (extension-p
+           (loop for (field . more) on (proto-fields message) doing
+             (when (proto-extension-p field)
+               (write-protobuf-as type field stream :indentation (+ indentation 2))
+               (when more
+                 (terpri stream)))))
+          (t
+           (loop for (enum . more) on (proto-enums message) doing
+             (write-protobuf-as type enum stream :indentation (+ indentation 2))
+             (when more
+               (terpri stream)))
+           (loop for (msg . more) on (proto-messages message) doing
+             (write-protobuf-as type msg stream :indentation (+ indentation 2))
+             (when more
+               (terpri stream)))
+           (loop for (field . more) on (proto-fields message) doing
+             (write-protobuf-as type field stream :indentation (+ indentation 2))
+             (when more
+               (terpri stream)))
+           (loop for (extension . more) on (proto-extensions message) doing
+             (write-protobuf-as type extension stream :indentation (+ indentation 2))
+             (when more
+               (terpri stream)))))

     (format stream ")")))
 
 (defparameter *protobuf-slot-comment-column* 56)
     (format stream ")")))
 
 (defparameter *protobuf-slot-comment-column* 56)


@@ -373,7 +387,7 @@
   (with-prefixed-accessors (from to) (proto-extension- extension)
     (format stream "~&~@[~VT~](define-extension ~D ~D)"
             (and (not (zerop indentation)) indentation)
   (with-prefixed-accessors (from to) (proto-extension- extension)
     (format stream "~&~@[~VT~](define-extension ~D ~D)"
             (and (not (zerop indentation)) indentation)

-            from to)))
+            from (if (eql to #.(1- (ash 1 29))) "max" to))))

 
 
 (defmethod write-protobuf-as ((type (eql :lisp)) (service protobuf-service) stream
 
 
 (defmethod write-protobuf-as ((type (eql :lisp)) (service protobuf-service) stream

diff --git a/proto-pkgdcl.lisp b/proto-pkgdcl.lisp
index 8a04af91ccc766fb9ce1b2cfe1f270ef910721f2..75f727ccd5d3b64b1a5321ea1b35f9f7c031aa51 100644 (file)
--- a/proto-pkgdcl.lisp
+++ b/proto-pkgdcl.lisp
@@ -104,8 +104,9 @@
    "PROTO-ENUMS"
    "PROTO-EXTENSION-FROM"
    "PROTO-EXTENSION-TO"
    "PROTO-ENUMS"
    "PROTO-EXTENSION-FROM"
    "PROTO-EXTENSION-TO"

-   "PROTO-EXTENSION-P"
+   "PROTO-EXTENDERS"

    "PROTO-EXTENSIONS"
    "PROTO-EXTENSIONS"

+   "PROTO-EXTENSION-P"

    "PROTO-FIELDS"
    "PROTO-FUNCTION"
    "PROTO-IMPORTS"
    "PROTO-FIELDS"
    "PROTO-FUNCTION"
    "PROTO-IMPORTS"