- Use 'defparameter' instead of 'defvar' where appropriate.
- Fix 'defvar' doc strings to distinguish between globals and "thread locals".
- Avoid using 'nconc'. introduce a new 'appendf' macro instead.
- Add a comment lamenting the fact that exporting something like 'proto-options'
also exports the writer '(setf proto-options)'. Fixed in Dylan.
;; If this schema has already been imported somewhere else,
;; mark it as imported here and carry on
(when imported
- (setf (proto-imported-schemas schema)
- (nconc (proto-imported-schemas schema) (list imported)))
+ (appendf (proto-imported-schemas schema) (list imported))
(return-from import-one))
(do-process-import import import-name)
(let* ((imported (find-schema (class-name->proto import-name))))
(when imported
- (setf (proto-imported-schemas schema)
- (nconc (proto-imported-schemas schema) (list imported))))
+ (appendf (proto-imported-schemas schema) (list imported)))
(return-from import-one))))))
(defun process-imports-from-file (imports-file)
(map () #'collect-form definers)
(ecase model-type
((define-enum)
- (setf (proto-enums schema) (nconc (proto-enums schema) (list model))))
+ (appendf (proto-enums schema) (list model)))
((define-type-alias)
- (setf (proto-type-aliases schema) (nconc (proto-type-aliases schema) (list model))))
+ (appendf (proto-type-aliases schema) (list model)))
((define-message define-extend)
(setf (proto-parent model) schema)
- (setf (proto-messages schema) (nconc (proto-messages schema) (list model)))
+ (appendf (proto-messages schema) (list model))
(when (eq (proto-message-type model) :extends)
- (setf (proto-extenders schema) (nconc (proto-extenders schema) (list model)))))
+ (appendf (proto-extenders schema) (list model))))
((define-service)
- (setf (proto-services schema) (nconc (proto-services schema) (list model)))))))
+ (appendf (proto-services schema) (list model))))))
(let ((var (intern (format nil "*~A*" type) *protobuf-package*)))
`(progn
,@forms
:value val-name
:parent enum)))
(collect-val val-name)
- (setf (proto-values enum) (nconc (proto-values enum) (list enum-val)))))
+ (appendf (proto-values enum) (list enum-val))))
(if alias-for
;; If we've got an alias, define a a type that is the subtype of
;; the Lisp enum so that typep and subtypep work
(map () #'collect-form definers)
(ecase model-type
((define-enum)
- (setf (proto-enums message) (nconc (proto-enums message) (list model))))
+ (appendf (proto-enums message) (list model)))
((define-type-alias)
- (setf (proto-type-aliases message) (nconc (proto-type-aliases message) (list model))))
+ (appendf (proto-type-aliases message) (list model)))
((define-message define-extend)
(setf (proto-parent model) message)
- (setf (proto-messages message) (nconc (proto-messages message) (list model)))
+ (appendf (proto-messages message) (list model))
(when (eq (proto-message-type model) :extends)
- (setf (proto-extenders message) (nconc (proto-extenders message) (list model)))))
+ (appendf (proto-extenders message) (list model))))
((define-group)
(setf (proto-parent model) message)
- (setf (proto-messages message) (nconc (proto-messages message) (list model)))
+ (appendf (proto-messages message) (list model))
(when extra-slot
(collect-slot extra-slot))
- (setf (proto-fields message) (nconc (proto-fields message) (list extra-field))))
+ (appendf (proto-fields message) (list extra-field)))
((define-extension)
- (setf (proto-extensions message) (nconc (proto-extensions message) (list model)))))))
+ (appendf (proto-extensions message) (list model))))))
(otherwise
(multiple-value-bind (field slot idx)
(process-field field index :conc-name conc-name :alias-for alias-for)
(setq index idx)
(when slot
(collect-slot slot))
- (setf (proto-fields message) (nconc (proto-fields message) (list field)))))))
+ (appendf (proto-fields message) (list field))))))
(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
(ecase model-type
((define-group)
(setf (proto-parent model) extends)
- (setf (proto-messages extends) (nconc (proto-messages extends) (list model)))
+ (appendf (proto-messages extends) (list model))
(when extra-slot
;;--- Refactor to get rid of all this duplicated code!
(let* ((inits (cdr extra-slot))
;; 'defsetf' needs to be visible at compile time
`((eval-when (:compile-toplevel :load-toplevel :execute)
(defsetf ,reader ,writer))))))))
- (setf (proto-message-type extra-field) :extends) ;this field is an extension
- (setf (proto-fields extends) (nconc (proto-fields extends) (list extra-field)))
- (setf (proto-extended-fields extends) (nconc (proto-extended-fields extends) (list extra-field)))))))
+ (setf (proto-message-type extra-field) :extends) ;this field is an extension
+ (appendf (proto-fields extends) (list extra-field))
+ (appendf (proto-extended-fields extends) (list extra-field))))))
(otherwise
(multiple-value-bind (field slot idx)
(process-field field index :conc-name conc-name :alias-for alias-for)
(setf (proto-reader field) reader
(proto-writer field) writer)))
(setf (proto-message-type field) :extends) ;this field is an extension
- (setf (proto-fields extends) (nconc (proto-fields extends) (list field)))
- (setf (proto-extended-fields extends) (nconc (proto-extended-fields extends) (list field)))))))
+ (appendf (proto-fields extends) (list field))
+ (appendf (proto-extended-fields extends) (list field))))))
`(progn
define-extend
,extends
(map () #'collect-form definers)
(ecase model-type
((define-enum)
- (setf (proto-enums message) (nconc (proto-enums message) (list model))))
+ (appendf (proto-enums message) (list model)))
((define-type-alias)
- (setf (proto-type-aliases message) (nconc (proto-type-aliases message) (list model))))
+ (appendf (proto-type-aliases message) (list model)))
((define-message define-extend)
(setf (proto-parent model) message)
- (setf (proto-messages message) (nconc (proto-messages message) (list model)))
+ (appendf (proto-messages message) (list model))
(when (eq (proto-message-type model) :extends)
- (setf (proto-extenders message) (nconc (proto-extenders message) (list model)))))
+ (appendf (proto-extenders message) (list model))))
((define-group)
(setf (proto-parent model) message)
- (setf (proto-messages message) (nconc (proto-messages message) (list model)))
+ (appendf (proto-messages message) (list model))
(when extra-slot
(collect-slot extra-slot))
- (setf (proto-fields message) (nconc (proto-fields message) (list extra-field))))
+ (appendf (proto-fields message) (list extra-field)))
((define-extension)
- (setf (proto-extensions message) (nconc (proto-extensions message) (list model)))))))
+ (appendf (proto-extensions message) (list model))))))
(otherwise
(multiple-value-bind (field slot idx)
(process-field field index :conc-name conc-name :alias-for alias-for)
(setq index idx)
(when slot
(collect-slot slot))
- (setf (proto-fields message) (nconc (proto-fields message) (list field)))))))
+ (appendf (proto-fields message) (list field))))))
(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
:options options
:documentation documentation
:source-location source-location)))
- (setf (proto-methods service) (nconc (proto-methods service) (list method)))
+ (appendf (proto-methods service) (list method))
;; The following are the hooks to an RPC implementation
(let* ((vrequest (intern (symbol-name 'request) package))
(vchannel (intern (symbol-name 'channel) package))
\f
;;; Ensure everything in a Protobufs schema is defined
-(defvar *undefined-messages*)
+(defvar *undefined-messages* nil
+ "Bound to a list of undefined messages during schame validation.")
;; A very useful tool during development...
(defun ensure-all-schemas ()
;;; Protocol buffers model classes
(defvar *all-schemas* (make-hash-table :test #'equal)
- "A table mapping names to 'protobuf-schema' objects.")
+ "A global table mapping names to 'protobuf-schema' objects.")
(defgeneric find-schema (name)
(:documentation
(defvar *all-messages* (make-hash-table :test #'equal)
- "A table mapping Lisp class names to 'protobuf-message' objects.")
+ "A global table mapping Lisp class names to 'protobuf-message' objects.")
(defgeneric find-message-for-class (class)
(:documentation
(values (gethash (class-name class) *all-messages*)))
-;; A few things (the pretty printer) want to keep track of the current schema
+;;; "Thread-local" variables
+
+;; Parsing (and even pretty printing schemas) want to keep track of the current schema
(defvar *protobuf* nil
- "The Protobufs object currently being defined, either a schema or a message.")
+ "Bound to the Protobufs object currently being defined, either a schema or a message.")
(defvar *protobuf-package* nil
- "The Lisp package in which the Protobufs schema is being defined.")
+ "Bound to the Lisp package in which the Protobufs schema is being defined.")
(defvar *protobuf-rpc-package* nil
- "The Lisp package in which the Protobufs schema's service definitions are being defined.")
+ "Bound to the Lisp package in which the Protobufs schema's service definitions are being defined.")
(defvar *protobuf-conc-name* nil
- "A global conc-name to use for all the messages in this schema. This controls
- the name of the accessors the fields of each message.
- When it's nil, there is no global conc-name.
+ "Bound to a conc-name to use for all the messages in the schema being defined.
+ This controls the name of the accessors the fields of each message.
+ When it's nil, there is no \"global\" conc-name.
When it's t, each message will use the message name as the conc-name.
When it's a string, that string will be used as the conc-name for each message.
'parse-schema-from-file' defaults conc-name to \"\", meaning that each field in
every message has an accessor whose name is the name of the field.")
(defvar *protobuf-pathname* nil
- "The name of the file from where the .proto file is being parsed.")
+ "Bound to he name of the file from where the .proto file is being parsed.")
(defvar *protobuf-search-path* ()
- "A search-path to use to resolve any relative pathnames.")
+ "Bound to the search-path to use to resolve any relative pathnames.")
(defvar *protobuf-output-path* ()
- "A path to use to direct output during imports, etc.")
+ "Bound to the path to use to direct output during imports, etc.")
;;; The model classes
(defclass abstract-protobuf () ())
+;; It would be nice if most of the slots had only reader functions, but
+;; that makes writing the Protobufs parser a good deal more complicated.
+;; Too bad Common Lisp exports '(setf foo)' when you only want to export 'foo'
(defclass base-protobuf (abstract-protobuf)
((class :type (or null symbol) ;the Lisp name for this object
:accessor proto-class ;this often names a type or class
(defmethod add-option ((options list) (name string) value &optional (type 'string))
(let ((option (find name options :key #'proto-name :test #'option-name=)))
- (setq options (append (remove option options)
- (list (make-option name value type))))))
+ (append (remove option options)
+ (list (make-option name value type)))))
(defgeneric remove-options (protobuf &rest names)
(:documentation
(expect-char stream terminator () "import")
(maybe-skip-comments stream))))
(process-imports schema (list import))
- (setf (proto-imports schema) (nconc (proto-imports schema) (list import)))))
+ (appendf (proto-imports schema) (list import))))
(defun parse-proto-option (stream protobuf &optional (terminators '(#\;)))
"Parse a Protobufs option line from 'stream'.
(maybe-skip-comments stream)))
(option (make-option key val)))
(cond (protobuf
- (setf (proto-options protobuf) (nconc (proto-options protobuf) (list option)))
+ (appendf (proto-options protobuf) (list option))
(values option terminator))
(t
;; If nothing to graft the option into, just return it as the value
(when (null name)
(expect-char stream #\} '(#\;) "enum")
(maybe-skip-comments stream)
- (setf (proto-enums protobuf) (nconc (proto-enums protobuf) (list enum)))
+ (appendf (proto-enums protobuf) (list enum))
(let ((type (find-option enum "lisp_name")))
(when type
(setf (proto-class enum) (make-lisp-symbol type))))
:index idx
:value (proto->enum-name name *protobuf-package*)
:parent enum)))
- (setf (proto-values enum) (nconc (proto-values enum) (list value)))
+ (appendf (proto-values enum) (list value))
value))
(when (null token)
(expect-char stream #\} '(#\;) "message")
(maybe-skip-comments stream)
- (setf (proto-messages protobuf) (nconc (proto-messages protobuf) (list message)))
+ (appendf (proto-messages protobuf) (list message))
(let ((type (find-option message "lisp_name")))
(when type
(setf (proto-class message) (make-lisp-symbol type))))
(when (null token)
(expect-char stream #\} '(#\;) "extend")
(maybe-skip-comments stream)
- (setf (proto-messages protobuf) (nconc (proto-messages protobuf) (list extends)))
- (setf (proto-extenders protobuf) (nconc (proto-extenders protobuf) (list extends)))
+ (appendf (proto-messages protobuf) (list extends))
+ (appendf (proto-extenders protobuf) (list extends))
(let ((type (find-option extends "lisp_name")))
(when type
(setf (proto-class extends) (make-lisp-symbol type))))
(return-from parse-proto-extend extends))
(cond ((member token '("required" "optional" "repeated") :test #'string=)
(let ((field (parse-proto-field stream extends token message)))
- (setf (proto-extended-fields extends) (nconc (proto-extended-fields extends) (list field)))))
+ (appendf (proto-extended-fields extends) (list field))))
((string= token "option")
(parse-proto-option stream extends))
(t
(let ((slot (find-option opts "lisp_name")))
(when slot
(setf (proto-value field) (make-lisp-symbol type))))
- (setf (proto-fields message) (nconc (proto-fields message) (list field)))
+ (appendf (proto-fields message) (list field))
field))))
(defmethod resolve-lisp-names ((field protobuf-field))
(assert (index-within-extensions-p idx extended-from) ()
"The index ~D is not in range for extending ~S"
idx (proto-class extended-from)))
- (setf (proto-fields message) (nconc (proto-fields message) (list field)))
+ (appendf (proto-fields message) (list field))
field))
(defun parse-proto-field-options (stream)
(let ((extension (make-instance 'protobuf-extension
:from from
:to (if (integerp to) to #.(1- (ash 1 29))))))
- (setf (proto-extensions message)
- (nconc (proto-extensions message)
- (list extension)))
+ (appendf (proto-extensions message) (list extension))
extension)))
(when (null token)
(expect-char stream #\} '(#\;) "service")
(maybe-skip-comments stream)
- (setf (proto-services schema) (nconc (proto-services schema) (list service)))
+ (appendf (proto-services schema) (list service))
(return-from parse-proto-service service))
(cond ((string= token "option")
(parse-proto-option stream service))
(let ((strm (find-option method "stream_type")))
(when strm
(setf (proto-streams-name method) strm)))
- (setf (proto-methods service) (nconc (proto-methods service) (list method)))
+ (appendf (proto-methods service) (list method))
method))
(defmethod resolve-lisp-names ((method protobuf-method))
(and (not (zerop indentation)) indentation) line))))
;; Lisp was born in 1958 :-)
-(defvar *lisp-options* '(("lisp_package" string 195801)
- ("lisp_name" string 195802)
- ("lisp_alias" string 195803)
- ("lisp_type" string 195804)
- ("lisp_class" string 195805)
- ("lisp_slot" string 195806)))
-
-(defvar *option-types* '(("ctype" symbol)
- ("deadline" float)
- ("deprecated" symbol)
- ("optimize_for" symbol)
- ("packed" boolean)
- ("protocol" symbol)
- ("stream_type" string)
- ;; Keep the rest of these in alphabetical order
- ("cc_api_version" integer)
- ("cc_generic_services" symbol)
- ("go_api_version" integer)
- ("go_generic_services" symbol)
- ("go_package" string)
- ("java_api_version" integer)
- ("java_generic_services" symbol)
- ("java_java5_enums" boolean)
- ("java_multiple_files" boolean)
- ("java_outer_classname" string)
- ("java_package" string)
- ("java_use_javaproto2" boolean)
- ("py_api_version" integer)
- ("py_generic_services" symbol)))
+(defparameter *lisp-options* '(("lisp_package" string 195801)
+ ("lisp_name" string 195802)
+ ("lisp_alias" string 195803)
+ ("lisp_type" string 195804)
+ ("lisp_class" string 195805)
+ ("lisp_slot" string 195806)))
+
+(defparameter *option-types* '(("ctype" symbol)
+ ("deadline" float)
+ ("deprecated" symbol)
+ ("optimize_for" symbol)
+ ("packed" boolean)
+ ("protocol" symbol)
+ ("stream_type" string)
+ ;; Keep the rest of these in alphabetical order
+ ("cc_api_version" integer)
+ ("cc_generic_services" symbol)
+ ("go_api_version" integer)
+ ("go_generic_services" symbol)
+ ("go_package" string)
+ ("java_api_version" integer)
+ ("java_generic_services" symbol)
+ ("java_java5_enums" boolean)
+ ("java_multiple_files" boolean)
+ ("java_outer_classname" string)
+ ("java_package" string)
+ ("java_use_javaproto2" boolean)
+ ("py_api_version" integer)
+ ("py_generic_services" symbol)))
(defmethod write-schema-header ((type (eql :proto)) (schema protobuf-schema) stream)
(when (any-lisp-option schema)
:pathname #p""
:components
((:file "pkgdcl")
- #-qres (:file "qtest")))
+ #-qres (:file "qtest")))
;; Wire format tests
(:module "wire-level-tests"
:serial t
;; Geodata hack
(:module "geodata-proto"
:pathname #p""
- :components
+ :components
((:protobuf-file "geodata")))
(:module "geodata-data"
:pathname #p""
- :components
+ :components
((:static-file "geodata.data")))
(:module "geodata"
:pathname #p""
- :depends-on ("geodata-proto" "geodata-data")
- :components
+ :depends-on ("geodata-proto" "geodata-data")
+ :components
((:file "geodata")))
;; Bob Brown's protocol buffers tests
(read-sequence golden-buffer golden-input)
(read-sequence test-buffer test-input)
(assert-true (equalp golden-buffer test-buffer))
- (DESCRIBE P)
- (DESCRIBE (DESERIALIZE-OBJECT (TYPE-OF P) TEST-BUFFER))
- (DESCRIBE (DESERIALIZE-OBJECT (TYPE-OF P) GOLDEN-BUFFER))))))
+ (DESCRIBE P)
+ (DESCRIBE (DESERIALIZE-OBJECT (TYPE-OF P) TEST-BUFFER))
+ (DESCRIBE (DESERIALIZE-OBJECT (TYPE-OF P) GOLDEN-BUFFER))))))
;; clean up
(delete-file *serial-pathname*)))
;;; Can a version of a Protobufs schema be upgraded to a new version
-(defvar *upgrade-warnings*)
+(defvar *upgrade-warnings* nil
+ "Bound to the list of upgrade warning messages.")
+
(defun upgrade-warn (format-string &rest format-args)
"Collect an upgrade warning into *upgrade-warnings*.
Returns the list of warnings."
,@body)))))
+(defmacro appendf (place tail)
+ "Append 'tail' to the list given by 'place', then set the place to the new list."
+ `(setf ,place (append ,place ,tail)))
+
+
;;; Functional programming, please
(defun curry (function &rest args)
;;; Code generation utilities
-(defvar *proto-name-separators* '(#\- #\_ #\/ #\space))
-(defvar *camel-case-field-names* nil)
+(defparameter *proto-name-separators* '(#\- #\_ #\/ #\space))
+(defparameter *camel-case-field-names* nil)
(defun find-proto-package (name)
"A very fuzzy definition of 'find-package'."
projects / cl-protobufs.git / commitdiff