From: Scott McKay Date: Wed, 18 Apr 2012 21:30:57 +0000 (+0000) Subject: Fully implement 'extends' X-Git-Url: https://asedeno.scripts.mit.edu/gitweb/?a=commitdiff_plain;ds=sidebyside;h=3760c4258a163b9541433f8b666b47a68398fdd4;p=cl-protobufs.git 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 1fd66f4..0a19630 100644 --- 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 - (: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 - (:conc-name color- - :documentation "A (named) color") + (:conc-name color-) (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)) @@ -260,11 +261,9 @@ following macros. For example:: (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) - :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 @@ -274,6 +273,14 @@ looks like this:: 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; @@ -284,6 +291,11 @@ looks like this:: required int64 rValue = 2; required int64 gValue = 3; required int64 bValue = 4; + extensions 1000 to max; + } + + extends Color { + optional int64 opacity = 1000; } message GetColorRequest { diff --git a/define-proto.lisp b/define-proto.lisp index 39279ce..84c22c3 100644 --- a/define-proto.lisp +++ b/define-proto.lisp @@ -46,7 +46,8 @@ :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) @@ -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-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))) @@ -117,7 +120,6 @@ :alias-for alias-for :options options :documentation documentation))) - (declare (type fixnum index)) (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 - :documentation documentation))) - (declare (type fixnum index)) + :documentation documentation)) + (*protobuf* message)) (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) - (macroexpand-1 fld env) + (macroexpand-1 field env) (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) - (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 - (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 @@ -255,10 +227,131 @@ (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. @@ -267,7 +360,7 @@ 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 diff --git a/examples.lisp b/examples.lisp index 905b7c9..acf6768 100644 --- 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) - (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)) @@ -555,10 +558,20 @@ service ColorWheel { (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 9af977d..00a4934 100644 --- a/model-classes.lisp +++ b/model-classes.lisp @@ -90,6 +90,10 @@ :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 @@ -101,8 +105,10 @@ (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)) @@ -118,13 +124,16 @@ 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)) - (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 @@ -231,6 +240,10 @@ :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 @@ -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 - (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)) @@ -261,14 +275,17 @@ (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)) - (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) @@ -300,8 +317,8 @@ :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 diff --git a/parser.lisp b/parser.lisp index 65c1e0c..c2bcb68 100644 --- a/parser.lisp +++ b/parser.lisp @@ -206,7 +206,8 @@ (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") @@ -249,7 +250,7 @@ (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) @@ -271,7 +272,7 @@ (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) @@ -298,7 +299,7 @@ (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") @@ -313,7 +314,7 @@ (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) @@ -322,7 +323,8 @@ (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) @@ -338,7 +340,8 @@ (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=) @@ -351,6 +354,47 @@ (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." @@ -379,7 +423,9 @@ :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)))) @@ -416,7 +462,7 @@ (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) @@ -441,7 +487,7 @@ 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)) diff --git a/printer.lisp b/printer.lisp index 6ea81cd..584d0b9 100644 --- a/printer.lisp +++ b/printer.lisp @@ -139,14 +139,19 @@ (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)))) @@ -167,7 +172,7 @@ (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 @@ -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))) - (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~]~]~ @@ -320,22 +327,29 @@ 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) @@ -373,7 +387,7 @@ (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 diff --git a/proto-pkgdcl.lisp b/proto-pkgdcl.lisp index 8a04af9..75f727c 100644 --- a/proto-pkgdcl.lisp +++ b/proto-pkgdcl.lisp @@ -104,8 +104,9 @@ "PROTO-ENUMS" "PROTO-EXTENSION-FROM" "PROTO-EXTENSION-TO" - "PROTO-EXTENSION-P" + "PROTO-EXTENDERS" "PROTO-EXTENSIONS" + "PROTO-EXTENSION-P" "PROTO-FIELDS" "PROTO-FUNCTION" "PROTO-IMPORTS"