X-Git-Url: https://asedeno.scripts.mit.edu/gitweb/?a=blobdiff_plain;f=parser.lisp;h=e533b066d34bae8d83b42346f349b7a34b4b59d2;hb=8035fae1dab4ff6ca9ce283671f8b1ee16b52c6a;hp=dd8a2931ef89d466d3b0574294dab9f38a525dba;hpb=311b32fe13d672c97472a6ccb0e2f7a74c81110d;p=cl-protobufs.git diff --git a/parser.lisp b/parser.lisp index dd8a293..e533b06 100644 --- a/parser.lisp +++ b/parser.lisp @@ -2,7 +2,7 @@ ;;; ;;; ;;; 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 ;;; ;;; ;;; @@ -288,9 +288,10 @@ :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 @@ -302,40 +303,61 @@ :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 position ~D" (file-position stream))))))))) (defun set-lisp-package (schema lisp-package-name) "Set the package for generated lisp names of 'schema'." @@ -349,8 +371,7 @@ (setq *protobuf-package* package))) (defmethod resolve-lisp-names ((schema protobuf-schema)) - "Recursively resolves protobuf type names to lisp type names in the messages and services in - 'schema'." + "Recursively resolves Protobuf type names to Lisp type names in the messages and services in 'schema'." (map () #'resolve-lisp-names (proto-messages schema)) (map () #'resolve-lisp-names (proto-services schema))) @@ -384,7 +405,7 @@ (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'. @@ -399,8 +420,8 @@ ((or (digit-char-p ch) (member ch '(#\- #\+ #\.))) (parse-number stream)) ((eql ch #\{) - ;;---bwagner: this is incorrect -- we need to find the field name in - ;; the locally-extended version of + ;;---bwagner: This is incorrect + ;; We need to find the field name in the locally-extended version of ;; google.protobuf.[File,Message,Field,Enum,EnumValue,Service,Method]Options ;; and get its type (let ((message (find-message (or protobuf *protobuf*) key))) @@ -413,11 +434,9 @@ (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 @@ -443,7 +462,7 @@ (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)))) @@ -470,7 +489,7 @@ :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)) @@ -497,7 +516,7 @@ (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)))) @@ -522,8 +541,7 @@ token (file-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))) @@ -535,7 +553,7 @@ (name (prog1 (parse-token stream) (expect-char stream #\{ () "extend") (maybe-skip-comments stream))) - ;;---bwagner: is 'extend' allowed to use a forward reference to a message? + ;;---bwagner: Is 'extend' allowed to use a forward reference to a message? (message (find-message protobuf name)) (extends (and message (make-instance 'protobuf-message @@ -559,8 +577,8 @@ (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)))) @@ -570,7 +588,7 @@ (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 @@ -622,7 +640,7 @@ (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)) @@ -637,8 +655,8 @@ (find-enum (proto-parent field) type))))) (unless (or ptype message) (error 'undefined-field-type - :type-name type - :field field)) + :type-name type + :field field)) (setf (proto-class field) (or ptype (proto-class message)))) nil) @@ -670,7 +688,7 @@ (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) @@ -706,9 +724,7 @@ (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))) @@ -732,7 +748,7 @@ (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)) @@ -759,8 +775,9 @@ (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)) @@ -781,50 +798,51 @@ (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)) "Resolves input, output, and streams protobuf type names to lisp type names and sets `proto-input-type', `proto-output-type', and, if `proto-streams-name' is set, `proto-streams-type' on 'method'." - (let* ((input-name (proto-input-name method)) - (output-name (proto-output-name method)) + (let* ((input-name (proto-input-name method)) + (output-name (proto-output-name method)) (streams-name (proto-streams-name method)) (service (proto-parent method)) - (schema (proto-parent service)) - (input-message (find-message schema input-name)) - (output-message (find-message schema output-name)) + (schema (proto-parent service)) + (input-message (find-message schema input-name)) + (output-message (find-message schema output-name)) (streams-message (and streams-name - ;; this is supposed to be the fully-qualified name, but we don't - ;; require that + ;; This is supposed to be the fully-qualified name, + ;; but we don't require that (find-message schema streams-name)))) (unless input-message (error 'undefined-input-type - :type-name input-name - :method method)) + :type-name input-name + :method method)) (unless output-message (error 'undefined-output-type - :type-name output-name - :method method)) + :type-name output-name + :method method)) (setf (proto-input-type method) (proto-class input-message)) (setf (proto-output-type method) (proto-class output-message)) (when streams-name (unless streams-message (error 'undefined-stream-type - :type-name streams-name - :method method)) + :type-name streams-name + :method method)) (setf (proto-streams-type method) (proto-class streams-message)))) nil) (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) @@ -837,4 +855,4 @@ (collect-option (parse-proto-option stream nil))) (expect-char stream #\} '(#\;) "service") (maybe-skip-comments stream) - options))) + (values options t))))