;;; ;;;
;;; Free Software published under an MIT-like license. See LICENSE ;;;
;;; ;;;
-;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;;
+;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;;
;;; ;;;
;;; Original author: Scott McKay ;;;
;;; ;;;
(member ch '(#\_ #\.)))))
+(defun parse-error-position (stream)
+ (if (typep stream 'file-stream)
+ (format nil " ~A:~D" (pathname stream) (file-position stream))
+ (format nil " position ~D" (file-position stream))))
+
+
(defun skip-whitespace (stream)
"Skip all the whitespace characters that are coming up in the stream."
(loop for ch = (peek-char nil stream nil)
(member (peek-char nil stream nil) char)
(eql (peek-char nil stream nil) char))
(setq ch (read-char stream))
- (error "No '~C' found~@[ within '~A'~] at position ~D"
- char within (file-position stream)))
+ (error "No '~C' found~@[ within '~A'~] at ~A"
+ char within (parse-error-position stream)))
(maybe-skip-chars stream chars)
ch))
(skip-whitespace stream)
(return-from maybe-skip-comments))
(otherwise
- (error "Found a '~C' at position ~D to start a comment, but no following '~C' or '~C'"
- #\/ (file-position stream) #\/ #\*))))))
+ (error "Found a '~C' at ~A to start a comment, but no following '~C' or '~C'"
+ #\/ (parse-error-position stream) #\/ #\*))))))
(defun skip-line-comment (stream)
"Skip to the end of a line comment, that is, to the end of the line.
:start-pos start :end-pos end)))
(defgeneric resolve-lisp-names (protobuf)
- (:documentation "Second pass of schema parsing which recursively resolves protobuf type names to
- lisp type names in all messages and services contained within 'protobuf'. No
- return value."))
+ (:documentation
+ "Second pass of schema parsing which recursively resolves Protobuf type names
+ to Lisp type names in all messages and services contained within 'protobuf'.
+ No return value."))
;; The syntax for Protocol Buffers is so simple that it doesn't seem worth
;; writing a sophisticated parser
:class class
:name name))
(*protobuf* schema)
- (*protobuf-package* *package*)
+ *protobuf-package*
+ *protobuf-rpc-package*
(*protobuf-conc-name* conc-name))
- (loop
- (skip-whitespace stream)
- (maybe-skip-comments stream)
- (let ((char (peek-char nil stream nil)))
- (cond ((null char)
- (remove-options schema "lisp_package")
- (resolve-lisp-names schema)
- (return-from parse-schema-from-stream schema))
- ((proto-token-char-p char)
- (let ((token (parse-token stream)))
- (cond ((string= token "syntax")
- (parse-proto-syntax stream schema))
- ((string= token "package")
- (parse-proto-package stream schema))
- ((string= token "import")
- (parse-proto-import stream schema))
- ((string= token "option")
- (let* ((option (parse-proto-option stream schema))
- (name (and option (proto-name option)))
- (value (and option (proto-value option))))
- (when (and option (option-name= name "lisp_package"))
- (set-lisp-package schema value))))
- ((string= token "enum")
- (parse-proto-enum stream schema))
- ((string= token "extend")
- (parse-proto-extend stream schema))
- ((string= token "message")
- (parse-proto-message stream schema))
- ((string= token "service")
- (parse-proto-service stream schema)))))
- (t
- (error "Syntax error at position ~D" (file-position stream))))))))
+ (labels ((ensure-package ()
+ "Find a fallback for our Lisp package if we don't have an obvious one already.
+ * java_package
+ * *package*"
+ (unless *protobuf-package*
+ (let ((java-package (find-option schema "java_package")))
+ (if java-package
+ (set-lisp-package schema java-package)
+ (setq *protobuf-package* *package*)))))
+ (ensure-rpc-package ()
+ (ensure-package)
+ (unless *protobuf-rpc-package*
+ (let ((rpc-package-name (format nil "~A-~A" (package-name *protobuf-package*) 'rpc)))
+ (setq *protobuf-rpc-package*
+ (or (find-proto-package rpc-package-name)
+ (make-package (string-upcase rpc-package-name) :use ())))))))
+ (loop
+ (skip-whitespace stream)
+ (maybe-skip-comments stream)
+ (let ((char (peek-char nil stream nil)))
+ (cond ((null char)
+ (remove-options schema "lisp_package")
+ (resolve-lisp-names schema)
+ (return-from parse-schema-from-stream schema))
+ ((proto-token-char-p char)
+ (let ((token (parse-token stream)))
+ (cond ((string= token "syntax")
+ (parse-proto-syntax stream schema))
+ ((string= token "package")
+ (parse-proto-package stream schema))
+ ((string= token "import")
+ (parse-proto-import stream schema))
+ ((string= token "option")
+ (let* ((option (parse-proto-option stream schema))
+ (name (and option (proto-name option)))
+ (value (and option (proto-value option))))
+ (when (and option (option-name= name "lisp_package"))
+ (set-lisp-package schema value))))
+ ((string= token "enum")
+ (ensure-package)
+ (parse-proto-enum stream schema))
+ ((string= token "extend")
+ (ensure-package)
+ (parse-proto-extend stream schema))
+ ((string= token "message")
+ (ensure-package)
+ (parse-proto-message stream schema))
+ ((string= token "service")
+ (ensure-rpc-package)
+ (parse-proto-service stream schema)))))
+ (t
+ (error "Syntax error at ~A" (parse-error-position stream)))))))))
(defun set-lisp-package (schema lisp-package-name)
"Set the package for generated lisp names of 'schema'."
(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'.
(t (kintern (parse-token stream)))))
(setq terminator (expect-char stream terminators () "option"))
(maybe-skip-comments stream)))
- (option (make-instance 'protobuf-option
- :name key
- :value val)))
+ (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))))
((string= token "extensions")
(parse-proto-extension stream message))
(t
- (error "Unrecognized token ~A at position ~D"
- token (file-position stream))))))))
+ (error "Unrecognized token ~A at ~A"
+ token (parse-error-position stream))))))))
(defmethod resolve-lisp-names ((message protobuf-message))
- "Recursively resolves protobuf type names to lisp type names in nested messages and fields of
- 'message'."
+ "Recursively resolves protobuf type names to lisp type names in nested messages and fields of 'message'."
(map () #'resolve-lisp-names (proto-messages message))
(map () #'resolve-lisp-names (proto-fields message)))
:class (proto-class message)
:name (proto-name message)
:qualified-name (proto-qualified-name message)
- :parent (proto-parent message)
+ :parent protobuf
:alias-for (proto-alias-for message)
:conc-name (proto-conc-name message)
:enums (copy-list (proto-enums message))
(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
- (error "Unrecognized token ~A at position ~D"
- token (file-position stream))))))))
+ (error "Unrecognized token ~A at ~A"
+ token (parse-error-position stream))))))))
(defun parse-proto-field (stream message required &optional extended-from)
"Parse a Protobufs field from 'stream'.
(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)
(t (parse-token stream))))))
(expect-char stream #\; () "message")
(assert (or (null token) (string= token "to")) ()
- "Expected 'to' in 'extensions' at position ~D" (file-position stream))
+ "Expected 'to' in 'extensions' at ~A" (parse-error-position stream))
(assert (or (integerp to) (string= to "max")) ()
- "Extension value is not an integer or 'max' as position ~D" (file-position stream))
+ "Extension value is not an integer or 'max' as ~A" (parse-error-position 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))
((string= token "rpc")
(parse-proto-method stream service (iincf index)))
(t
- (error "Unrecognized token ~A at position ~D"
- token (file-position stream))))))))
+ (error "Unrecognized token ~A at ~A"
+ token (parse-error-position stream))))))))
(defmethod resolve-lisp-names ((service protobuf-service))
"Recursively resolves protobuf type names to lisp type names for all methods of 'service'."
(out (prog2 (expect-char stream #\( () "service")
(parse-token stream)
(expect-char stream #\) () "service")))
- (opts (let ((opts (parse-proto-method-options stream)))
- (when (or (null opts) (eql (peek-char nil stream nil) #\;))
+ (opts (multiple-value-bind (opts bodyp)
+ (parse-proto-method-options stream)
+ (when (or (not bodyp) (eql (peek-char nil stream nil) #\;))
(expect-char stream #\; () "service"))
(maybe-skip-comments stream)
opts))
:options opts
:source-location (make-source-location stream loc (i+ loc (length name))))))
(assert (string= ret "returns") ()
- "Syntax error in 'message' at position ~D" (file-position stream))
+ "Syntax error in 'message' at ~A" (parse-error-position stream))
(let* ((name (find-option method "lisp_name"))
(stub (or (and name (make-lisp-symbol name))
stub)))
(setf (proto-class method) stub
- (proto-client-stub method) stub
- (proto-server-stub method) (intern (format nil "~A-~A" 'do stub) *protobuf-package*)))
+ (proto-client-stub method) (intern (format nil "~A-~A" 'call stub) *protobuf-rpc-package*)
+ (proto-server-stub method) (intern (format nil "~A-~A" stub 'impl) *protobuf-rpc-package*)))
(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))
(defun parse-proto-method-options (stream)
"Parse any options in a Protobufs method from 'stream'.
- Returns a list of 'protobuf-option' objects."
+ Returns a list of 'protobuf-option' objects.
+ If a body was parsed, returns a second value T."
(when (eql (peek-char nil stream nil) #\{)
(expect-char stream #\{ () "service")
(maybe-skip-comments stream)
(when (eql (peek-char nil stream nil) #\})
(return))
(assert (string= (parse-token stream) "option") ()
- "Syntax error in 'message' at position ~D" (file-position stream))
+ "Syntax error in 'message' at ~A" (parse-error-position stream))
(collect-option (parse-proto-option stream nil)))
(expect-char stream #\} '(#\;) "service")
(maybe-skip-comments stream)
- options)))
+ (values options t))))
projects / cl-protobufs.git / blobdiff