X-Git-Url: https://asedeno.scripts.mit.edu/gitweb/?a=blobdiff_plain;f=parser.lisp;h=26c72053905756e254ddbfeb07c85595b9fea72e;hb=53404bf93a572d058012667df1c83159d0a9fed5;hp=c252d3bbe6c0c7762abfb1c91dbefec0ed2958cf;hpb=3447256965ab1b262fe7b8381e99a25cbe0b4762;p=cl-protobufs.git diff --git a/parser.lisp b/parser.lisp index c252d3b..26c7205 100644 --- a/parser.lisp +++ b/parser.lisp @@ -1,8 +1,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; -;;; Confidential and proprietary information of ITA Software, Inc. ;;; +;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; -;;; Copyright (c) 2012 ITA Software, Inc. All rights reserved. ;;; +;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Scott McKay ;;; ;;; ;;; @@ -17,20 +17,20 @@ (declaim (inline proto-whitespace-char-p)) (defun proto-whitespace-char-p (ch) - (locally (declare (optimize (speed 3) (safety 0) (debug 0))) - (and ch (member ch '(#\space #\tab #\return #\newline))))) + (declare #.$optimize-fast-unsafe) + (and ch (member ch '(#\space #\tab #\return #\newline)))) (declaim (inline proto-eol-char-p)) (defun proto-eol-char-p (ch) - (locally (declare (optimize (speed 3) (safety 0) (debug 0))) - (and ch (member ch '(#\return #\newline))))) + (declare #.$optimize-fast-unsafe) + (and ch (member ch '(#\return #\newline)))) (declaim (inline proto-token-char-p)) (defun proto-token-char-p (ch) - (locally (declare (optimize (speed 3) (safety 0) (debug 0))) - (and ch (or (alpha-char-p ch) - (digit-char-p ch) - (member ch '(#\_ #\.)))))) + (declare #.$optimize-fast-unsafe) + (and ch (or (alpha-char-p ch) + (digit-char-p ch) + (member ch '(#\_ #\.))))) (defun skip-whitespace (stream) @@ -81,11 +81,11 @@ ((#\*) (skip-block-comment stream)) ((nil) + (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) #\/ #\*))))) - (skip-whitespace stream)) + #\/ (file-position stream) #\/ #\*)))))) (defun skip-line-comment (stream) "Skip to the end of a line comment, that is, to the end of the line. @@ -156,7 +156,11 @@ collect ch into string finally (progn (skip-whitespace stream) - (return (coerce string 'string))))) + (if (eql (peek-char nil stream nil) ch0) + ;; If the next character is a quote character, that means + ;; we should go parse another string and concatenate it + (return (strcat (coerce string 'string) (parse-string stream))) + (return (coerce string 'string)))))) (defun unescape-char (stream) "Parse the next \"escaped\" character from the stream." @@ -259,12 +263,35 @@ :direction :input :external-format :utf-8 :element-type 'character) - (let ((*compile-file-pathname* (pathname stream)) + (let ((*protobuf-pathname* (pathname stream)) + (*compile-file-pathname* (pathname stream)) (*compile-file-truename* (truename stream))) (parse-schema-from-stream stream - :name (or name (class-name->proto (pathname-name (pathname stream)))) - :class (or class (kintern (pathname-name (pathname stream)))) - :conc-name conc-name)))) + :name (or name (class-name->proto (pathname-name (pathname stream)))) + :class (or class (kintern (pathname-name (pathname stream)))) + :conc-name conc-name)))) + +;; 'with-proto-source-location' counts on this being a 3-element list +;; Yeah, it's a kludge, but we really don't need anything complicated for this +(defstruct (source-location (:type list) (:constructor %make-source-location)) + pathname + start-pos + end-pos) + +(defun make-source-location (stream start end) + "Create a \"source locator\" for the stream at the current position. + With any luck, we can get meta-dot to pay attention to it." + (declare (ignore stream)) + ;; Don't record source locations if we're not parsing from a file + (and *protobuf-pathname* + (%make-source-location :pathname *protobuf-pathname* + :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.")) ;; The syntax for Protocol Buffers is so simple that it doesn't seem worth ;; writing a sophisticated parser @@ -276,43 +303,77 @@ :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") - (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")) - (let ((package (or (find-package value) - (find-package (string-upcase value)) - *protobuf-package*))) - (setf (proto-lisp-package schema) value) - (setq *protobuf-package* package))))) - ((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'." + (check-type schema protobuf-schema) + (check-type lisp-package-name string) + (let ((package (or (find-proto-package lisp-package-name) + ;; Try to put symbols into the right package + (make-package (string-upcase lisp-package-name) :use ()) + *protobuf-package*))) + (setf (proto-lisp-package schema) lisp-package-name) + (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'." + (map () #'resolve-lisp-names (proto-messages schema)) + (map () #'resolve-lisp-names (proto-services schema))) (defun parse-proto-syntax (stream schema &optional (terminator #\;)) "Parse a Protobufs syntax line from 'stream'. @@ -334,20 +395,16 @@ (substitute #\- #\_ package)))) (setf (proto-package schema) package) (unless (proto-lisp-package schema) - (setf (proto-lisp-package schema) lisp-pkg)) - (let ((package (or (find-package lisp-pkg) - (find-package (string-upcase lisp-pkg)) - *protobuf-package*))) - (setq *protobuf-package* package)))) + (set-lisp-package schema lisp-pkg)))) (defun parse-proto-import (stream schema &optional (terminator #\;)) "Parse a Protobufs import line from 'stream'. - Updates the 'protobuf-schema' object to use the package." + Updates the 'protobuf-schema' object to use the import." (check-type schema protobuf-schema) (let ((import (prog1 (parse-string stream) - (expect-char stream terminator () "package") + (expect-char stream terminator () "import") (maybe-skip-comments stream)))) - (process-imports schema import) + (process-imports schema (list import)) (setf (proto-imports schema) (nconc (proto-imports schema) (list import))))) (defun parse-proto-option (stream protobuf &optional (terminators '(#\;))) @@ -362,6 +419,18 @@ (parse-string stream)) ((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 + ;; google.protobuf.[File,Message,Field,Enum,EnumValue,Service,Method]Options + ;; and get its type + (let ((message (find-message (or protobuf *protobuf*) key))) + (if message + ;; We've got a complex message as a value to an option + ;; This only shows up in custom options + (parse-text-format message :stream stream :parse-name nil) + ;; Who knows what to do? Skip the value + (skip-field stream)))) (t (kintern (parse-token stream))))) (setq terminator (expect-char stream terminators () "option")) (maybe-skip-comments stream))) @@ -380,12 +449,16 @@ "Parse a Protobufs 'enum' from 'stream'. Updates the 'protobuf-schema' or 'protobuf-message' object to have the enum." (check-type protobuf (or protobuf-schema protobuf-message)) - (let* ((name (prog1 (parse-token stream) + (let* ((loc (file-position stream)) + (name (prog1 (parse-token stream) (expect-char stream #\{ () "enum") (maybe-skip-comments stream))) (enum (make-instance 'protobuf-enum :class (proto->class-name name *protobuf-package*) - :name name))) + :name name + :qualified-name (make-qualified-name protobuf name) + :parent protobuf + :source-location (make-source-location stream loc (i+ loc (length name)))))) (loop (let ((name (parse-token stream))) (when (null name) @@ -401,11 +474,12 @@ (return-from parse-proto-enum enum)) (if (string= name "option") (parse-proto-option stream enum) - (parse-proto-enum-value stream enum name)))))) + (parse-proto-enum-value stream protobuf enum name)))))) -(defun parse-proto-enum-value (stream enum name) +(defun parse-proto-enum-value (stream protobuf enum name) "Parse a Protobufs enum value from 'stream'. Updates the 'protobuf-enum' object to have the enum value." + (declare (ignore protobuf)) (check-type enum protobuf-enum) (expect-char stream #\= () "enum") (let* ((idx (prog1 (parse-signed-int stream) @@ -413,8 +487,10 @@ (maybe-skip-comments stream))) (value (make-instance 'protobuf-enum-value :name name + :qualified-name (make-qualified-name enum name) :index idx - :value (proto->enum-name name *protobuf-package*)))) + :value (proto->enum-name name *protobuf-package*) + :parent enum))) (setf (proto-values enum) (nconc (proto-values enum) (list value))) value)) @@ -423,15 +499,19 @@ "Parse a Protobufs 'message' from 'stream'. Updates the 'protobuf-schema' or 'protobuf-message' object to have the message." (check-type protobuf (or protobuf-schema protobuf-message)) - (let* ((name (prog1 (or name (parse-token stream)) + (let* ((loc (file-position stream)) + (name (prog1 (or name (parse-token stream)) (expect-char stream #\{ () "message") (maybe-skip-comments stream))) + (class (proto->class-name name *protobuf-package*)) (message (make-instance 'protobuf-message - :class (proto->class-name name *protobuf-package*) - :name name + :class class + :name name + :qualified-name (make-qualified-name protobuf name) :parent protobuf - ;; Force accessors for all slots - :conc-name *protobuf-conc-name*)) + ;; Maybe force accessors for all slots + :conc-name (conc-name-for-type class *protobuf-conc-name*) + :source-location (make-source-location stream loc (i+ loc (length name))))) (*protobuf* message)) (loop (let ((token (parse-token stream))) @@ -462,27 +542,38 @@ (error "Unrecognized token ~A at position ~D" 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'." + (map () #'resolve-lisp-names (proto-messages message)) + (map () #'resolve-lisp-names (proto-fields message))) + (defun parse-proto-extend (stream protobuf) "Parse a Protobufs 'extend' from 'stream'. Updates the 'protobuf-schema' or 'protobuf-message' object to have the message." (check-type protobuf (or protobuf-schema protobuf-message)) - (let* ((name (prog1 (parse-token stream) + (let* ((loc (file-position stream)) + (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? (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) + :class (proto-class message) + :name (proto-name message) + :qualified-name (proto-qualified-name message) + :parent protobuf :alias-for (proto-alias-for message) + :conc-name (proto-conc-name message) :enums (copy-list (proto-enums message)) :messages (copy-list (proto-messages message)) :fields (copy-list (proto-fields message)) :extensions (copy-list (proto-extensions message)) - :message-type :extends))) ;this message is an extension + :message-type :extends ;this message is an extension + :source-location (make-source-location stream loc (i+ loc (length name)))))) (*protobuf* extends)) + (assert message () + "There is no message named ~A to extend" name) (loop (let ((token (parse-token stream))) (when (null token) @@ -520,25 +611,21 @@ (expect-char stream #\; () "message") (maybe-skip-comments stream))) (packed (find-option opts "packed")) - (ptype (if (member type '("int32" "int64" "uint32" "uint64" "sint32" "sint64" - "fixed32" "fixed64" "sfixed32" "sfixed64" - "string" "bytes" "bool" "float" "double") :test #'string=) - (kintern type) - type)) - (class (if (keywordp ptype) ptype (proto->class-name type *protobuf-package*))) (slot (proto->slot-name name *protobuf-package*)) (reqd (kintern required)) (field (make-instance 'protobuf-field :name name :type type - :class class + :qualified-name (make-qualified-name message name) + :parent message ;; One of :required, :optional or :repeated :required reqd :index idx :value slot ;; Fields parsed from .proto files usually get an accessor - :reader (and *protobuf-conc-name* - (intern (format nil "~A~A" *protobuf-conc-name* slot) *protobuf-package*)) + :reader (let ((conc-name (proto-conc-name message))) + (and conc-name + (intern (format nil "~A~A" conc-name slot) *protobuf-package*))) :default (multiple-value-bind (default type default-p) (find-option opts "default") (declare (ignore type)) @@ -558,6 +645,23 @@ (setf (proto-fields message) (nconc (proto-fields message) (list field))) field)))) +(defmethod resolve-lisp-names ((field protobuf-field)) + "Resolves the field's protobuf type to a lisp type and sets `proto-class' for 'field'." + (let* ((type (proto-type field)) + (ptype (when (member type '("int32" "int64" "uint32" "uint64" "sint32" "sint64" + "fixed32" "fixed64" "sfixed32" "sfixed64" + "string" "bytes" "bool" "float" "double") :test #'string=) + (kintern type))) + (message (unless ptype + (or (find-message (proto-parent field) type) + (find-enum (proto-parent field) type))))) + (unless (or ptype message) + (error 'undefined-field-type + :type-name type + :field field)) + (setf (proto-class field) (or ptype (proto-class message)))) + nil) + (defun parse-proto-group (stream message required &optional extended-from) "Parse a (deprecated) Protobufs group from 'stream'. Updates the 'protobuf-message' object to have the group type and field." @@ -567,18 +671,19 @@ (name (slot-name->proto (proto->slot-name type))) (idx (parse-unsigned-int stream)) (msg (parse-proto-message stream message type)) - (class (proto->class-name type *protobuf-package*)) (slot (proto->slot-name name *protobuf-package*)) (field (make-instance 'protobuf-field :name name :type type - :class class + :qualified-name (make-qualified-name message name) + :parent message :required (kintern required) :index idx :value slot - ;; Groups parsed from .proto files always get an accessor - :reader (and *protobuf-conc-name* - (intern (format nil "~A~A" *protobuf-conc-name* slot) *protobuf-package*)) + ;; Groups parsed from .proto files usually get an accessor + :reader (let ((conc-name (proto-conc-name message))) + (and conc-name + (intern (format nil "~A~A" conc-name slot) *protobuf-package*))) :message-type :group))) (setf (proto-message-type msg) :group) (when extended-from @@ -602,8 +707,7 @@ (multiple-value-bind (option term) (parse-proto-option stream nil '(#\] #\,)) (setq terminator term) - (collect-option option)))) - options)) + (collect-option option)))))) (defun parse-proto-extension (stream message) (check-type message protobuf-message) @@ -632,12 +736,16 @@ "Parse a Protobufs 'service' from 'stream'. Updates the 'protobuf-schema' object to have the service." (check-type schema protobuf-schema) - (let* ((name (prog1 (parse-token stream) + (let* ((loc (file-position stream)) + (name (prog1 (parse-token stream) (expect-char stream #\{ () "service") (maybe-skip-comments stream))) (service (make-instance 'protobuf-service :class (proto->class-name name *protobuf-package*) - :name name)) + :name name + :qualified-name (make-qualified-name *protobuf* name) + :parent schema + :source-location (make-source-location stream loc (i+ loc (length name))))) (index 0)) (loop (let ((token (parse-token stream))) @@ -654,43 +762,91 @@ (error "Unrecognized token ~A at position ~D" token (file-position stream)))))))) +(defmethod resolve-lisp-names ((service protobuf-service)) + "Recursively resolves protobuf type names to lisp type names for all methods of 'service'." + (map () #'resolve-lisp-names (proto-methods service))) + (defun parse-proto-method (stream service index) "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)) + (let* ((loc (file-position stream)) + (name (parse-token stream)) (in (prog2 (expect-char stream #\( () "service") (parse-token stream) (expect-char stream #\) () "service"))) - (ret (parse-token stream)) + (ret (parse-token stream)) ;should be "=>" (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)) + (stub (proto->class-name name *protobuf-package*)) (method (make-instance 'protobuf-method - :class (proto->class-name name *protobuf-package*) + :class stub :name name - :input-type (proto->class-name in *protobuf-package*) + :qualified-name (make-qualified-name *protobuf* name) + :parent service :input-name in - :output-type (proto->class-name out *protobuf-package*) :output-name out :index index - :options opts))) - (let ((name (find-option method "lisp_name"))) - (when name - (setf (proto-function method) (make-lisp-symbol name)))) + :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)) + (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) (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))) 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)) + (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)) + (streams-message (and streams-name + ;; 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)) + (unless output-message + (error 'undefined-output-type + :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)) + (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) @@ -703,4 +859,4 @@ (collect-option (parse-proto-option stream nil))) (expect-char stream #\} '(#\;) "service") (maybe-skip-comments stream) - options))) + (values options t))))